CTITLE SAVADMZ -- DETERMINE THE DEPTH VARIABLE DOWNWARD CONT. GRID 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA 00020000 CA AUTHOR JAMES C. SUN 00030000 CA LANGUAGE FORTRAN 00040000 CA SYSTEM IBM AND CRAY 00050000 CA WRITTEN 03/26/87 00060000 C REVISED 02/15/90 JJC - MODIFIED TO MEET EDP SPARC STANDARDS. 00070000 C REVISED 03/24/92 ESN - CONVERTED TO THE IBM. 00080000 CA 00090000 CA CALL SAVADMZ(Z,VMIN,VMAX,WOB,IWFLAG,WORK,IZSBLK, 00100000 CA + IZEBLK,TLFT,DTB,NTB,ANTRNC,IPR) 00110000 CA 00120000 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00130000 CA 00140000 CA OUT Z R4 DEPTH GRID COORDINATE FOR DOWNWARD CONT. 00150000 CA IN VMIN R4 MINIMUM VELOCITY FOR EACH LAYER 00160000 CA IN VMAX R4 MINIMUM VELOCITY FOR EACH LAYER 00170000 CA OUT WOB R4 SPECTRAL SHAPING ARRAY 00180000 CA OUT IWFLAG I4 DIFFRACTION CONTROL FLAG ARRAY 00190000 CA IN/OUT WORK R4 WORK ARRAY 00200000 CA OUT IZSBLK I4 STARTING DEPTH INDEX ARRAY 00210000 CA OUT IZEBLK I4 ENDING DEPTH INDEX ARRAY 00220000 CA OUT TLFT R4 MAX. TIME REMAINED IN THE TRACE 00230000 CA OUT DTB R4 TIME TO PAD BACK TO THE NEW TRACE 00240000 CA IN ANTRNC R4 TRACE TRNCATION CONTROL 00250000 CA IN IPR I4 PRINTER NUMBER 00260000 CA 00270000 CA THIS SUBROUTINE DETERMINES THE DEPTH VARIABLE DOWNWARD CONT. GRID 00280000 CA 00290000 CD ARRAY DIMENSION REQUIREMENT: 00300000 CD 00310000 CD REAL 00320000 CD Z - NZ 00330000 CD VMIN - NZ 00340000 CD VMAX - NZ 00350000 CD WOB - NZ 00360000 CD IWFLAG - NZ 00370000 CD WORK - NSG 00380000 CD IZSBLK - NBLK 00390000 CD IZEBLK - NBLK 00400000 CD TLFT - NBLK 00410000 CD DTB - NBLK 00420000 CD NTB - NBLK 00430000 CD 00440000 CD 00450000 C 00460000 SUBROUTINE SAVADMZ(Z,VMIN,VMAX,WOB,IWFLAG,WORK,IZSBLK, 00470000 + IZEBLK,TLFT,DTB,NTB,ANTRNC,IPR) 00480000 C 00490000 IMPLICIT INTEGER(A-Z) 00500000 C 00510000 COMMON /USER/ SLOCAL(50), ULOCAL(450) 00520000 C 00530000 REAL Z 00540000 REAL VMIN 00550000 REAL VMAX 00560000 REAL WOB 00570000 REAL WORK 00580000 REAL TLFT 00590000 REAL DTB 00600000 REAL ANTRNC 00610000 REAL ZMAX 00620000 REAL DZ 00630000 REAL DIPC 00640000 REAL DEN 00650000 REAL VMINZ 00660000 REAL DZM 00670000 REAL DZW 00680000 REAL TT 00690000 REAL VR2 00700000 REAL VI 00710000 REAL DELZ 00720000 REAL VRMS 00730000 REAL VALF 00740000 REAL XH 00750000 REAL XHM2 00760000 REAL XX 00770000 REAL PKM 00780000 REAL TMAX 00790000 REAL DT 00800000 REAL TTEST 00810000 REAL TMIN 00820000 REAL ZBLK 00830000 REAL VMAXZ 00840000 REAL ZDTMX 00850000 REAL TLEFT 00860000 REAL T0 00870000 C 00880000 EQUIVALENCE (ZDTMX , ULOCAL( 19)) 00890000 EQUIVALENCE (IDIP , ULOCAL( 20)) 00900000 EQUIVALENCE (DZ , ULOCAL( 21)) 00910000 EQUIVALENCE (NZ , ULOCAL( 22)) 00920000 EQUIVALENCE (NZM , ULOCAL( 23)) 00930000 EQUIVALENCE (NBLK , ULOCAL( 27)) 00940000 EQUIVALENCE (DZW , ULOCAL( 31)) 00950000 EQUIVALENCE (MZDIF , ULOCAL( 32)) 00960000 EQUIVALENCE (IZCORR , ULOCAL( 45)) 00970000 EQUIVALENCE (NT , ULOCAL( 58)) 00980000 EQUIVALENCE (DT , ULOCAL( 59)) 00990000 EQUIVALENCE (IFHI , ULOCAL( 70)) 01000000 EQUIVALENCE (VALF , ULOCAL( 87)) 01010000 EQUIVALENCE (XHM2 , ULOCAL( 88)) 01020000 EQUIVALENCE (PKM , ULOCAL( 89)) 01030000 C 01040000 DIMENSION Z(1) 01050000 DIMENSION VMIN(1) 01060000 DIMENSION VMAX(1) 01070000 DIMENSION WOB(1) 01080000 DIMENSION IWFLAG(1) 01090000 DIMENSION WORK(1) 01100000 DIMENSION IZSBLK(1) 01110000 DIMENSION IZEBLK(1) 01120000 DIMENSION TLFT(1) 01130000 DIMENSION DTB(1) 01140000 DIMENSION NTB(1) 01150000 C 01160000 C 01170000 CALL PTST1R('VMIN',VMIN,NZ,IPR) 01180000 CALL PTST1R('VMAX',VMAX,NZ,IPR) 01190000 ZMAX=DZ*NZ 01200000 DIPC=1.+FLOAT(IDIP)*(FLOAT(IDIP)*.0002611-.0090556) 01210000 DEN=4.*FLOAT(IFHI)*DIPC 01220000 C 01230000 C 01240000 IZ=1 01250000 Z(1)=0 01260000 VMINZ=VMIN(1) 01270000 IWFLAG(1)=IFHI 01280000 C 01290000 C 01300000 100 IZ=IZ+1 01310000 DZM=AMAX1(VMINZ/DEN,DZ) 01320000 MZ=NINT(DZM/DZ) 01330000 C 01340000 C MZ=MAX0(MZ,1) 01350000 C 01360000 MZ=MAX0(MZ,MZDIF) 01370000 DZM=DZM/FLOAT(MZ) 01380000 DZM=AMAX1(DZM,DZ) 01390000 IWFLAG(IZ)=INT((VMINZ+0.00001)/(4.*DIPC*DZM)) 01400000 IF(IZ.EQ.2 .AND. DZW.NE.0.) THEN 01410000 DZM=DZW 01420000 Z(IZ)=Z(IZ-1)+DZM 01430000 GO TO 140 01440000 ENDIF 01450000 DO 120 I=1,MZ 01460000 Z(IZ)=Z(IZ-1)+DZM 01470000 IF(Z(IZ).GE.ZMAX .OR. IZ.GE.NZ) GO TO 160 01480000 IF(I.NE.MZ) THEN 01490000 IZ=IZ+1 01500000 IWFLAG(IZ)=IWFLAG(IZ-1) 01510000 ENDIF 01520000 120 CONTINUE 01530000 C 01540000 C 01550000 140 CONTINUE 01560000 JZ=INT((Z(IZ)+0.00001)/DZ)+1 01570000 VMINZ=VMIN(JZ) 01580000 GO TO 100 01590000 C 01600000 C 01610000 160 CONTINUE 01620000 C 01630000 C 01640000 NZM=IZ-1 01650000 WRITE(IPR,8000) NZM 01660000 8000 FORMAT(/,' NZM =',I5) 01670000 CALL PTST1R('Z ',Z,NZM,IPR) 01680000 CALL PTST1I('IWFG',IWFLAG,NZM,IPR) 01690000 C 01700000 C 01710000 TT = 0.0 01720000 VR2 = 0.0 01730000 WOB(1) = 0.0 01740000 DO 180 I=2,NZM 01750000 IND = INT((Z(I-1)+0.0001)/DZ)+1 01760000 VI = (VMIN(IND)+VMAX(IND))/2. 01770000 DELZ = Z(I)-Z(I-1) 01780000 TT = TT + 2.*DELZ/VI 01790000 VR2 = VR2 + 2.*DELZ*VI 01800000 VRMS = SQRT(VR2/TT) 01810000 IF (VRMS .GT. VALF) THEN 01820000 XH = TT/SQRT(1./VALF**2-1./VRMS**2) 01830000 ELSE 01840000 XH = XHM2 01850000 ENDIF 01860000 XX = AMIN1(XH,XHM2) 01870000 WOB(I) = VRMS*PKM*Z(I)/XX 01880000 C 01890000 C WRITE (IPR,650) I,Z(I),TT,VI,VRMS,XH,XX,WOB(I) 01900000 C 650 FORMAT(' I,Z(I),TT,VI,VRMS,XH,XX,WOB(I): ',I5,F8.1,F8.3, 01910000 C * 4F10.1,E15.6) 01920000 C 01930000 180 CONTINUE 01940000 C 01950000 C 01960000 TMAX=NT*DT 01970000 IBLK=1 01980000 IZSBLK(1)=1 01990000 TTEST=(NTB(IBLK+1)-1)*DT 02000000 TMIN=0. 02010000 ZBLK=999999. 02020000 IBFLAG=1 02030000 C 02040000 C 02050000 VMAXZ=VMAX(1) 02060000 C 02070000 C 02080000 DO 200 IZ=2,NZM 02090000 DZM=Z(IZ)-Z(IZ-1) 02100000 IF(Z(IZ).GT.ZDTMX) THEN 02110000 TMIN=TMIN+2.*DZM/VMAXZ 02120000 ENDIF 02130000 TLEFT=TMAX-TMIN 02140000 C 02150000 C WRITE(IPR,3003) IBLK,IZ,Z(IZ),TMIN,TLEFT,TTEST,ZDTMX 02160000 C3003 FORMAT(' IBLK,IZ,Z =',2I4,E12.5,' TMIN,TLEFT,TTEST =',3E12.5, 02170000 C + ' ZDTMX =',E12.5) 02180000 C 02190000 IF(TLEFT.LT.TTEST .AND. IBFLAG.EQ.1) THEN 02200000 IF(IBLK.EQ.1 .AND. IZ.EQ.2) THEN 02210000 ZBLK=Z(IZ)+2.*IZCORR*.05 02220000 ELSE 02230000 ZBLK=Z(IZ)+2.*IZCORR+2.*DZM 02240000 ENDIF 02250000 T0=TMIN 02260000 C 02270000 C WRITE(IPR,3001) TMAX,TMIN,TLEFT,TTEST,Z(IZ),ZBLK 02280000 C3001 FORMAT(' TMAX,TMIN,TLEFT,TTEST =',4E13.5,/, 02290000 C + ' ZL,ZBLK =',2E13.5) 02300000 C 02310000 IF(IBLK.GE.NBLK) GO TO 220 02320000 C 02330000 C TTEST=(NTB(IBLK+1)-1)*DT 02340000 C 02350000 IF(ZBLK/Z(NZM).GT.0.95) GO TO 220 02360000 IBFLAG=0 02370000 ENDIF 02380000 C 02390000 C 02400000 IF(Z(IZ).GE.ZBLK .AND. IBFLAG.EQ.0) THEN 02410000 IBFLAG=1 02420000 IZEBLK(IBLK)=IZ 02430000 TLFT(IBLK)=TLEFT 02440000 DTB(IBLK)=TMIN-T0 02450000 CCC WRITE(IPR,8020) TMIN,TLFT(IBLK),Z(IZ) 02460000 C8020 FORMAT(' TMIN,TLFH(IBLK),Z(IZ) =',3E13.5) 02470000 IF(IBLK.GE.NBLK) GO TO 220 02480000 IBLK=IBLK+1 02490000 IZSBLK(IBLK)=IZ+1 02500000 IF(IBLK.LT.NBLK) THEN 02510000 TTEST=(NTB(IBLK+1)-1)*DT 02520000 ELSE 02530000 TTEST=0. 02540000 ENDIF 02550000 ENDIF 02560000 C 02570000 C 02580000 JZ=NINT((Z(IZ)+0.00001)/DZ)+1 02590000 VMAXZ=VMAX(JZ) 02600000 200 CONTINUE 02610000 C 02620000 C 02630000 220 IZEBLK(IBLK)=NZM 02640000 NBLK=IBLK 02650000 C 02660000 C 02670000 RETURN 02680000 END 02690000