PGF90 (Version 12.8) 08/30/2020 00:27:49 page 1 Switches: -noasm -nodclchk -nodebug -nodlines -noline -list -idir ../include -inform warn -opt 1 -nosave -object -noonetrip -depchk on -nostandard -nosymbol -noupcase Filename: eta2p.f90 ( 1) subroutine eta2p ( 2) ( 3) USE mod_vrbls ( 4) USE mod_extra ( 5) USE mod_masks ( 6) USE mod_pvrbls ( 7) USE mod_graph ( 8) ( 9) implicit none ( 10) include 'param_o.h' ( 11) !!JNT include 'extra.comm' ../include/param_o.h ( 1)* integer,parameter :: im0=401 ( 2)* integer, parameter :: nm=6 ( 3)* integer, parameter :: lm = 50 ( 4)* integer, parameter :: nsub = 10 ( 5)* ( 6)* integer, parameter :: im=im0, jm=im ( 7)* integer, parameter :: im1=im-1, jm1=jm-1 ( 8)* ( 9)* integer, parameter :: lm1 = lm-1, lp1 =lm +1 ( 10)* ( 11)* integer, parameter :: ixm = nsub, jym = ixm, nxy = ixm*jym ( 12)* integer, parameter :: ildom = (im - 1)/ixm, jldom = (jm - 1)/jym ( 13)* integer, parameter :: ilm = (im - 1)/ixm +1, jlm = (jm - 1)/jym +1 ( 14)* ( 15)* logical,parameter::flat=.false. ( 16)* logical,parameter::hstst=.false. ( 17)* ( 18)*! integer,parameter::igm=360, jgm = 181 ( 19)* integer,parameter::igm=(im0-1)*4, jgm = (igm/2)+1 ( 20)* real,parameter::alfa=0.0, beta=0.0, gamm=0.0 ( 21)*! real,parameter::alfa=0.*3.1415926/180.,beta=66.*3.1415926/180. & ( 22)*! ,gamm=175.*3.1415926/180. ( 23)* ( 24)*!GSM integer,parameter::lsm=20 ( 25)* integer,parameter::lsm=31 ( 26)* ( 27)*!RESTART ( 28)* ( 29)* character(len=10):: restartdate='2020080412' !restart date to create appropriate folder name ( 12) include 'mapot.comm' ../include/mapot.comm ( 1)* real,dimension(lsm)::spl,alsl ( 2)* ( 3)* common/mapot/ spl,alsl ( 13) include 'const.h' ../include/const.h ( 1)* logical :: run, first, restrt, subpost ( 2)* integer :: nfcst,nbc,list,ntsd,nddamp,nprec, & ( 3)* nboco,nshde,ncp,ntddmp PGF90 (Version 12.8) 08/30/2020 00:27:49 page 2 ( 4)* logical,parameter::lcornerm=.FALSE. ( 5)* ( 6)* real,parameter :: dt=40 ! length of each time step ( 7)* logical,parameter:: sigma=.false. ( 8)*!GSM integer,parameter::outnum=40 ! number of outputs ( 9)*!GSM integer,parameter::nday=10 ! number of days ( 10)* integer,parameter:: ntstm=3600*24*10/dt ! total time steps ( 11)*! integer,parameter:: idtad=1 ( 12)*! integer,parameter:: ncnvc=45 ( 13)*!test integer,parameter::nphs=45 ( 14)* ( 15)* integer,parameter:: idtad=2 ( 16)* integer,parameter:: ncnvc=6 ( 17)* integer,parameter::nphs=6 ( 18)* ( 19)* ( 20)* integer,parameter::nradsh=1 ( 21)*!GSM integer,parameter::nradlh=2 ( 22)* integer,parameter::nradlh=1 ( 23)* real,parameter::tsph=3600./dt ( 24)* integer,parameter::nrads=tsph*nradsh ( 25)* integer,parameter::nradl=tsph*nradlh ( 26)* real,parameter::weig=0.25 ( 27)* ( 28)*! ( 29)*! parameters for diagnostics ( 30)*! ( 31)* ( 32)* integer,parameter::idgns=10 ( 33)* integer,parameter::dgnstr=24*3600*200/dt ( 34)* integer,parameter::dgnnum=(ntstm-dgnstr)/idgns+1 ( 35)* integer,parameter::ickmm=1 ( 36)* ( 37)*! ( 38)*! parameter for initial values ( 39)*! ( 40)* real(KIND=4),parameter::pt = 2500.0 ( 41)*!!!test Dragan 1dec2015 ( 42)*!! real,parameter::pt=1000 ( 43)* ( 44)*! ( 45)*! date ( 46)*! ( 47)* integer::idat(3) ( 48)*!GSM data idat/07,21,2020/ ( 49)*!GSM integer::ihrst=0 ( 50)* ( 51)*! variable sst ( 52)* logical::lvsst ( 53)* ( 54)*! data assimilation constants ( 55)* ( 56)* integer,parameter::ndassim=3*3600/dt ( 57)*! integer,parameter::ndassimm=8*ndassim ( 58)* integer,parameter::ndassimm=0 ( 59)* integer,parameter::outstr=ndassimm ! step at which starts output ( 60)* integer,parameter::outend= ntstm+ndassimm ! step at which ends output ( 61)*!GSM integer,parameter::iout=(outend-outstr)/outnum ! steps between two output PGF90 (Version 12.8) 08/30/2020 00:27:49 page 3 ( 62)* ( 63)*! data choice ( 64)* ( 65)* integer,parameter::sstc=1 ! 1 is NCEP sst data ( 66)* ! 2 is TMI sst data ( 67)* ( 68)* ( 14) include 'dynam.comm' ../include/dynam.comm ( 1)* real::fadv,fadv2, fadt, rd, f4d, ef4t, fkin ( 2)* real, dimension (lm) :: deta, rdeta, aeta, daeta,f4q2 ( 3)* real, dimension (lp1) :: eta, dfl ( 4)* ( 5)* common/dynam/ fadv,fadv2,fadt,rd,f4d,f4q2,ef4t,fkin,deta,rdeta, & ( 6)* eta,dfl,aeta,daeta ( 7)* ( 8)* ( 9)*!!!!!!!!!!!copy from dynam_comm.h ( 10)*! real :: fadv, fadv2,fadt, rd, f4d, ef4t, fkin, fcp ( 11)*! real, dimension (lm) :: deta, rdeta, aeta, daeta,f4q2 ( 12)*! real, dimension (lp1) :: eta, dfl ( 13)*! real, dimension (0:im+1,0:jm+1,nm) :: wpdar, f11, f12, f21, f22, & ( 14)*! p11, p12, p21, p22, fdiv, fddmp,fvdiff & ( 15)*! ,hbmsk,hsinp,hcosp ( 16)*! common /dynam/ fadv,fadv2, fadt, rd, f4d,f4q2, ef4t, fkin, & ( 17)*! deta, rdeta, aeta, eta, dfl, daeta, & ( 18)*! wpdar, f11, f12, f21, f22, & ( 19)*! p11, p12, p21, p22, fcp, fdiv, fddmp,hsinp,hcosp,& ( 20)*! fvdiff,hbmsk ( 15) include 'params' ( 16) ../include/params ( 1)* real,parameter::p1000=1000.e2,CAPA=0.28589641E0 ( 17) integer,parameter::im_jm_nm=(im+2)*(jm+2)*nm ( 18) real,parameter::g=9.80616,RD1=287.04,GAMMA=6.5E-3, & ( 19) RGAMOG=RD1*GAMMA/G,PQ0=379.90516,A2=17.2693882 & ( 20) , A3=273.16,A4=35.86 ( 21) integer::nhold,lp,i,j,n,lsl,nn,l,lmb,il ( 22) !!JNT real,dimension(0:im+1,0:jm+1,nm)::tsl,qsl,fsl,q2sl ( 23) !!JNT real,dimension(0:im+1,0:jm+1,nm,lm)::iw ( 24) !!JNT integer,dimension(0:im+1,0:jm+1,nm)::nl1x ( 25) !!JNT integer,dimension(im_jm_nm)::ihold,jhold,nnhold ( 26) ( 27) real, allocatable, dimension(:,:,:)::tsl,qsl,fsl,q2sl ( 28) real, allocatable, dimension(:,:,:,:)::iw ( 29) integer, allocatable, dimension(:,:,:)::nl1x ( 30) integer, allocatable, dimension(:)::ihold,jhold,nnhold ( 31) real::pnl1,B,fac,pu,tu,tabv,pl,tl,tabo,ahf,tblo,petau,alpetu, & ( 32) petal,alpetl,alpet2,fact,alpet1,trf,zu,qu,ai,bi,tmt0,tmt15, & ( 33) qw,qi,qint,qsat,utim,climit,lml,hh,tkl,qkl,cwmkl,pp, & ( 34) u00kl,fiq,iwu,qabv,rhu,bq,ahfq,ql,iwl,rhl,qblo,q2a,bq2, & ( 35) q2b,ahfq2 ( 36) !!JNT real,dimension(0:im+1,0:jm+1,nm)::alpetux,alpet2x,usl,vsl ( 37) real, allocatable, dimension(:,:,:)::alpetux,alpet2x,usl,vsl ( 38) ( 39) ! print *,'u,v,',u(10,10,6,6),v(10,10,6,6) ( 40) ! print *,'us,vs,',u(10,10,6,6)*u2us(10,10,6)+v2us(10,10,6)*v(10,10,6,6) ( 41) ! print *,'us,vs,',u(10,10,6,6)*u2vs(10,10,6)+v2vs(10,10,6)*v(10,10,6,6) PGF90 (Version 12.8) 08/30/2020 00:27:49 page 4 ( 42) ( 43) UTIM=1. ( 44) CLIMIT =1.0E-20 ( 45) ( 46) ALLOCATE(tsl(0:im+1,0:jm+1,nm)) ( 47) ALLOCATE(qsl(0:im+1,0:jm+1,nm)) ( 48) ALLOCATE(fsl(0:im+1,0:jm+1,nm)) ( 49) ALLOCATE(q2sl(0:im+1,0:jm+1,nm)) ( 50) ALLOCATE(iw(0:im+1,0:jm+1,nm,lm)) ( 51) ( 52) ALLOCATE(nl1x(0:im+1,0:jm+1,nm)) ( 53) ( 54) ALLOCATE(ihold(im_jm_nm)) ( 55) ALLOCATE(jhold(im_jm_nm)) ( 56) ALLOCATE(nnhold(im_jm_nm)) ( 57) ( 58) ALLOCATE(alpetux(0:im+1,0:jm+1,nm)) ( 59) ALLOCATE(alpet2x(0:im+1,0:jm+1,nm)) ( 60) ALLOCATE(usl(0:im+1,0:jm+1,nm)) ( 61) ALLOCATE(vsl(0:im+1,0:jm+1,nm)) ( 62) ( 63) do n=1,nm ( 64) DO J=1,jm ( 65) DO I=1,IM ( 66) IW(I,J,n,1)=0. ( 67) ENDDO ( 68) ENDDO ( 69) ENDDO ( 70) !C ( 71) DO L=2,LM ( 72) do n=1,nm ( 73) DO J=1,jm ( 74) DO I=1,IM ( 75) LML=LM-LMH(I,J,n) ( 76) HH=HTM(I,J,n,L) ( 77) TKL=T(I,J,n,L) ( 78) QKL=Q(I,J,n,L) ( 79) CWMKL=W(I,J,n,L) ( 80) TMT0=(TKL-273.16)*HH ( 81) TMT15=AMIN1(TMT0,-15.)*HH ( 82) PP=PDSL(I,J,n)*AETA(L)+PT ( 83) QW=HH*PQ0/PP*EXP(HH*A2*(TKL-A3)/(TKL-A4)) ( 84) QI=QW*(1.+0.01*AMIN1(TMT0,0.)) ( 85) U00KL=U00(I,J,n)+UL(L+LML)*(0.95-U00(I,J,n))*UTIM ( 86) !C ( 87) IF(TMT0.LT.-15.0)THEN ( 88) FIQ=QKL-U00KL*QI ( 89) IF(FIQ.GT.0..OR.CWMKL.GT.CLIMIT) THEN ( 90) IW(I,J,n,L)=1. ( 91) ELSE ( 92) IW(I,J,n,L)=0. ( 93) ENDIF ( 94) !C ( 95) IF(TMT0.GE.0.0)IW(I,J,n,L)=0. ( 96) IF(TMT0.LT.0.0.AND.TMT0.GE.-15.0)THEN ( 97) IW(I,J,n,L)=0. ( 98) IF(IW(I,J,n,L-1).EQ.1.0.AND.CWMKL.GT.CLIMIT)IW(I,J,n,L)=1. ( 99) ENDIF PGF90 (Version 12.8) 08/30/2020 00:27:49 page 5 ( 100) endif ( 101) enddo ( 102) enddo ( 103) enddo ( 104) enddo ( 105) open(1,file='tmpfld.dat',form='unformatted') ( 106) lsl=lsm ( 107) DO 310 LP=1,LSL ( 108) NHOLD=0 ( 109) ( 110) TRF=2.*ALSL(LP) ( 111) ( 112) do 125 n=1,nm ( 113) DO 125 J=1,jm ( 114) DO 125 I=1,IM ( 115) ! ( 116) TSL(I,J,n)=-1.E6 ( 117) QSL(I,J,n)=-1.E6 ( 118) FSL(I,J,n)=-1.E6 ( 119) ! ( 120) !*** LOCATE VERTICAL INDEX OF MODEL INTERFACE JUST BELOW ( 121) !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ( 122) ! ( 123) DO 115 L=2,LM ( 124) ! if(i.eq.25.and.j.eq.22.and.n.eq.3)then ( 125) ! print *,l,alpint(i,j,n,l),alsl(lp),alpint(i,j,n,lp1) ( 126) ! endif ( 127) IF(ALPINT(I,J,n,L).GE.ALSL(LP))THEN ( 128) NL1X(I,J,n)=L ( 129) NHOLD=NHOLD+1 ( 130) IHOLD(NHOLD)=I ( 131) JHOLD(NHOLD)=J ( 132) nnhold(nhold)=n ( 133) GO TO 125 ( 134) ENDIF ( 135) 115 CONTINUE ( 136) nl1x(i,j,n)=l ( 137) NHOLD=NHOLD+1 ( 138) IHOLD(NHOLD)=I ( 139) JHOLD(NHOLD)=J ( 140) nnhold(nhold)=n ( 141) ! ( 142) 125 CONTINUE ( 143) ( 144) DO 220 NN=1,NHOLD ( 145) I=IHOLD(NN) ( 146) J=JHOLD(NN) ( 147) n=nnHOLD(NN) ( 148) PNL1=PINT(I,J,n,NL1X(I,J,n)) ( 149) IF(NL1X(I,J,n).EQ.1)THEN ( 150) !--------------------------------------------------------------------- ( 151) !*** EXTRAPOLATE ABOVE THE TOPMOST MIDLAYER OF THE MODEL ( 152) !--------------------------------------------------------------------- ( 153) ! ( 154) PU=PINT(I,J,n,2) ( 155) ZU=ZINT(I,J,n,2) ( 156) TU=0.5*(T(I,J,n,1)+T(I,J,n,2)) ( 157) QU=0.50*(Q(I,J,n,1)+Q(I,J,n,2)) PGF90 (Version 12.8) 08/30/2020 00:27:49 page 6 ( 158) IWU=0.5*(IW(I,J,n,1)+IW(I,J,n,2)) ( 159) ( 160) TABV=TU*(SPL(LP)/PU)**RGAMOG ( 161) ( 162) TMT0=TU-273.16 ( 163) TMT15=AMIN1(TMT0,-15.) ( 164) AI=0.008855 ( 165) BI=1. ( 166) IF(TMT0.LT.-20.)THEN ( 167) AI=0.007225 ( 168) BI=0.9674 ( 169) ENDIF ( 170) QW=PQ0/PU*EXP(A2*(TU-A3)/(TU-A4)) ( 171) QI=QW*(BI+AI*AMIN1(TMT0,0.)) ( 172) QINT=QW*(1.-0.00032*TMT15*(TMT15+15.)) ( 173) IF(TMT0.LT.-15.)THEN ( 174) QSAT=QI ( 175) ELSEIF(TMT0.GE.0.)THEN ( 176) QSAT=QINT ( 177) ELSE ( 178) IF(IWU.GT.0.0) THEN ( 179) QSAT=QI ( 180) ELSE ( 181) QSAT=QINT ( 182) ENDIF ( 183) ENDIF ( 184) !CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT ( 185) !C DELETE THIS LINE TO SWITCH BACK TO RH VS ICE ( 186) QSAT=QW ( 187) !CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT ( 188) RHU =QU/QSAT ( 189) !C ( 190) IF(RHU.GT.1)THEN ( 191) RHU=1 ( 192) QU =RHU*QSAT ( 193) ENDIF ( 194) ( 195) IF(RHU.LT.0.01)THEN ( 196) RHU=0.01 ( 197) QU =RHU*QSAT ( 198) ENDIF ( 199) ( 200) TMT0=TABV-273.16 ( 201) TMT15=AMIN1(TMT0,-15.) ( 202) AI=0.008855 ( 203) BI=1. ( 204) IF(TMT0.LT.-20.)THEN ( 205) AI=0.007225 ( 206) BI=0.9674 ( 207) ENDIF ( 208) QW=PQ0/SPL(LP)*EXP(A2*(TABV-A3)/(TABV-A4)) ( 209) QI=QW*(BI+AI*AMIN1(TMT0,0.)) ( 210) QINT=QW*(1.-0.00032*TMT15*(TMT15+15.)) ( 211) IF(TMT0.LT.-15.)THEN ( 212) QSAT=QI ( 213) ELSEIF(TMT0.GE.0.)THEN ( 214) QSAT=QINT ( 215) ELSE PGF90 (Version 12.8) 08/30/2020 00:27:49 page 7 ( 216) IF(IWU.GT.0.0) THEN ( 217) QSAT=QI ( 218) ELSE ( 219) QSAT=QINT ( 220) ENDIF ( 221) ENDIF ( 222) ( 223) !CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT ( 224) !C DELETE THIS LINE TO SWITCH BACK TO RH VS ICE ( 225) QSAT=QW ( 226) !CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT ( 227) QABV =RHU*QSAT ( 228) QABV =AMAX1(1.e-12,QABV) ( 229) ( 230) B =TABV ( 231) BQ =QABV ( 232) FAC =0. ( 233) AHF =0. ( 234) AHFQ =0. ( 235) Q2A =0.50*(Q2(I,J,n,1)+Q2(I,J,n,2)) ( 236) BQ2 =Q2A ( 237) ELSEIF(NL1X(I,J,n).EQ.LP1)THEN ( 238) !--------------------------------------------------------------------- ( 239) !*** EXTRAPOLATE BELOW LOWEST MODEL MIDLAYER (BUT STILL ABOVE GROUND) ( 240) !--------------------------------------------------------------------- ( 241) ! ( 242) PL=PINT(I,J,n,LM-1) ( 243) TL=0.5*(T(I,J,n,LM-2)+T(I,J,n,LM-1)) ( 244) QL=0.5*(Q(I,J,n,LM-2)+Q(I,J,n,LM-1)) ( 245) IWL=0.50*(IW(I,J,n,LM-2)+IW(I,J,n,LM-1)) ( 246) TBLO=TL*(SPL(LP)/PL)**RGAMOG ( 247) ( 248) TMT0=TL-273.16 ( 249) TMT15=AMIN1(TMT0,-15.) ( 250) AI=0.008855 ( 251) BI=1. ( 252) IF(TMT0.LT.-20.)THEN ( 253) AI=0.007225 ( 254) BI=0.9674 ( 255) ENDIF ( 256) QW=PQ0/PL*EXP(A2*(TL-A3)/(TL-A4)) ( 257) QI=QW*(BI+AI*AMIN1(TMT0,0.)) ( 258) QINT=QW*(1.-0.00032*TMT15*(TMT15+15.)) ( 259) IF(TMT0.LT.-15.)THEN ( 260) QSAT=QI ( 261) ELSEIF(TMT0.GE.0.)THEN ( 262) QSAT=QINT ( 263) ELSE ( 264) IF(IWL.GT.0.0) THEN ( 265) QSAT=QI ( 266) ELSE ( 267) QSAT=QINT ( 268) ENDIF ( 269) ENDIF ( 270) !CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT ( 271) !C DELETE THIS LINE TO SWITCH BACK TO RH VS ICE ( 272) QSAT=QW ( 273) !CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT PGF90 (Version 12.8) 08/30/2020 00:27:49 page 8 ( 274) RHL=QL/QSAT ( 275) IF(RHL.GT.1)THEN ( 276) RHL=1 ( 277) QL =RHL*QSAT ( 278) ENDIF ( 279) ( 280) IF(RHL.LT..01)THEN ( 281) RHL=.01 ( 282) QL =RHL*QSAT ( 283) ENDIF ( 284) TMT0=TBLO-273.16 ( 285) TMT15=AMIN1(TMT0,-15.) ( 286) AI=0.008855 ( 287) BI=1. ( 288) IF(TMT0.LT.-20.)THEN ( 289) AI=0.007225 ( 290) BI=0.9674 ( 291) ENDIF ( 292) QW=PQ0/SPL(L) & ( 293) *EXP(A2*(TBLO-A3)/(TBLO-A4)) ( 294) QI=QW*(BI+AI*AMIN1(TMT0,0.)) ( 295) QINT=QW*(1.-0.00032*TMT15*(TMT15+15.)) ( 296) IF(TMT0.LT.-15.)THEN ( 297) QSAT=QI ( 298) ELSEIF(TMT0.GE.0.)THEN ( 299) QSAT=QINT ( 300) ELSE ( 301) IF(IWL.GT.0.0) THEN ( 302) QSAT=QI ( 303) ELSE ( 304) QSAT=QINT ( 305) ENDIF ( 306) ENDIF ( 307) !CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT ( 308) !C DELETE THIS LINE TO SWITCH BACK TO RH VS ICE ( 309) QSAT=QW ( 310) !CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT ( 311) QBLO =RHL*QSAT ( 312) QBLO =AMAX1(1.e-12,QBLO) ( 313) ( 314) B =TBLO ( 315) BQ =QBLO ( 316) FAC =0. ( 317) AHF =0. ( 318) AHFQ =0. ( 319) Q2A =0.50*(Q2(I,J,n,LMH(I,J,n)-1)+Q2(I,J,n,LMH(I,J,n))) ( 320) BQ2 =Q2A ( 321) ELSE ( 322) !--------------------------------------------------------------------- ( 323) !*** INTERPOLATION BETWEEN NORMAL LOWER AND UPPER BOUNDS ( 324) !--------------------------------------------------------------------- ( 325) ! ( 326) B =T(I,J,n,NL1X(I,J,n)) ( 327) BQ =Q(I,J,n,NL1X(I,J,n)) ( 328) FAC =2.*ALOG(PT+PDSL(I,J,n)*AETA(NL1X(I,J,n))) ( 329) AHF =(B-T(I,J,n,NL1X(I,J,n)-1))/ & ( 330) (ALPINT(I,J,n,NL1X(I,J,n)+1)-ALPINT(I,J,n,NL1X(I,J,n)-1)) ( 331) AHFQ =(BQ-Q(I,J,n,NL1X(I,J,n)-1))/ & PGF90 (Version 12.8) 08/30/2020 00:27:49 page 9 ( 332) (ALPINT(I,J,n,NL1X(I,J,n)+1)-ALPINT(I,J,n,NL1X(I,J,n)-1)) ( 333) ( 334) Q2B =0.50*(Q2(I,J,n,NL1X(I,J,n)-1)+Q2(I,J,n,NL1X(I,J,n))) ( 335) !C ( 336) IF(NL1X(I,J,n).GT.2)THEN ( 337) Q2A=0.50*(Q2(I,J,n,NL1X(I,J,n)-2)+Q2(I,J,n,NL1X(I,J,n)-1)) ( 338) ELSE ( 339) Q2A=Q2B ( 340) ENDIF ( 341) !C ( 342) BQ2=Q2B*HTM(I,J,n,NL1X(I,J,n)) ( 343) AHFQ2=(BQ2-Q2A*HTM(I,J,n,NL1X(I,J,n)-1))/ & ( 344) (ALPINT(I,J,n,NL1X(I,J,n)+1)-ALPINT(I,J,n,NL1X(I,J,n)-1)) ( 345) if(i.eq.25.and.j.eq.22.and.n.eq.3)then ( 346) ! print *,'tsl,',lp,nl1x(i,j,n),ahf,ALPINT(I,J,n,NL1X(I,J,n)+1) & ( 347) ! ,ALPINT(I,J,n,NL1X(I,J,n)-1) ( 348) endif ( 349) ( 350) ENDIF ( 351) ( 352) TSL(I,J,n)=B+AHF*(TRF-FAC) ( 353) QSL(I,J,n)=BQ+AHFQ*(TRF-FAC) ( 354) QSL(I,J,n)=AMAX1(QSL(I,J,n),1.e-12) ( 355) Q2SL(I,J,n)=BQ2+AHFQ2*(TRF-FAC) ( 356) Q2SL(I,J,n)=AMAX1(Q2SL(I,J,n),0.) ( 357) ( 358) ( 359) ( 360) ( 361) ( 362) ( 363) FSL(I,J,n)=(PNL1-SPL(LP))/(SPL(LP)+PNL1) & ( 364) *((ALSL(LP)+ALPINT(I,J,n,NL1X(I,J,n))-FAC)*AHF+B)*Rd*2. & ( 365) +ZINT(I,J,n,NL1X(I,J,n))*G ( 366) if(i.eq.25.and.j.eq.22.and.n.eq.3)then ( 367) ! print *,'tsl,',lp,tsl(i,j,n),b,ahf,trf,fac,nl1x(i,j,n) ( 368) endif ( 369) 220 CONTINUE ( 370) ( 371) do 281 n=1,nm ( 372) DO 281 J=1,jm ( 373) DO 281 I=1,IM ( 374) !NOTE ( 375) !NOTE 29 JANUARY 1993, RUSS TREADON. ( 376) !NOTE - AS FOR THE OTHER FIELDS WE INTERPOLATE ONLY ( 377) !NOTE BETWEEN THE FAL AND THE MODEL TOP. BELOW ( 378) !NOTE SURFACE VALUES ARE FAL VALUES. ( 379) ! ( 380) LMB = LMV(I,J,n) ( 381) ! ( 382) PETAU=PT+PDVP1(I,J,n)*ETA(1) ( 383) ALPETU=ALOG(PETAU) ( 384) DO 280 IL=2,LMB ( 385) PETAL=PT+PDVP1(I,J,n)*ETA(IL) ( 386) ! PETAU=PT+PDVP1(I,J)*ETA(IL-1) ( 387) ALPETL=ALOG(PETAL) ( 388) ! ALPETU=ALOG(PETAU) ( 389) ALPET2=SQRT(0.5E0*(ALPETL*ALPETL+ALPETU*ALPETU)) PGF90 (Version 12.8) 08/30/2020 00:27:49 page 10 ( 390) ! ( 391) ! SEARCH FOR HIGHEST MID-LAYER ETA SURFACE (NOT SUBMERGED) ( 392) ! THAT IS BELOW THE GIVEN STANDARD PRESSURE LEVEL. ( 393) IF(ALSL(Lp).LT.ALPET2)THEN ( 394) NL1X(I,J,n)=IL-1 ( 395) ALPETUX(I,J,n)=ALPETU ( 396) ALPET2X(I,J,n)=ALPET2 ( 397) GO TO 281 ( 398) ENDIF ( 399) ! If we arent on the last iterate of the 280 loop, reset PETAU and ALPETU ( 400) if ( il .eq. lmb ) goto 280 ( 401) PETAU=PETAL ( 402) ALPETU=ALPETL ( 403) 280 CONTINUE ( 404) NL1X(I,J,n)=LMB+1 ( 405) ALPETUX(I,J,n)=ALPETU ( 406) ALPET2X(I,J,n)=ALPET2 ( 407) 281 CONTINUE ( 408) ! ( 409) ! BELOW GROUND USE FAL WINDS. ( 410) ! ( 411) !$omp parallel do ( 412) !$omp private(alpet1,alpetl,alpetu,fact,petau) ( 413) do 290 n=1,nm ( 414) DO 290 J=1,jm ( 415) DO 290 I=1,IM ( 416) IF(NL1X(I,J,n).GT.LMV(I,J,n))THEN ( 417) USL(I,J,n)=U(I,J,n,LMV(I,J,n)) ( 418) VSL(I,J,n)=V(I,J,n,LMV(I,J,n)) ( 419) ! ( 420) ! IF REQUESTED PRESSURE LEVEL IS NOT BELOW THE LOCAL GROUND ( 421) ! THEN WE HAVE TWO POSSIBILITIES. IF THE REQUESTED PRESSURE ( 422) ! LEVEL IS BETWEEN THE LOCAL SURFACE PRESSURE AND TOP OF ( 423) ! MODEL PRESSURE, VERTICALLY INTERPOLATE BETWEEN NEAREST ( 424) ! BOUNDING ETA LEVELS TO GET THE WIND COMPONENTS. IF THE ( 425) ! REQUESTED PRESSURE LEVEL IS ABOVE THE MODEL TOP, USE ( 426) ! CONSTANT EXTRAPOLATION OF TOP ETA LAYER (L=1) WINDS. ( 427) ! ( 428) ELSE ( 429) IF(NL1X(I,J,n).GT.1)THEN ( 430) ALPETL=ALPETUX(I,J,n) ( 431) PETAU=PT+PDVP1(I,J,n)*ETA(NL1X(I,J,n)-1) ( 432) ALPETU=ALOG(PETAU) ( 433) ALPET1=SQRT(0.5*(ALPETL*ALPETL+ALPETU*ALPETU)) ( 434) FACT=(ALPET2X(I,J,n)-ALSL(Lp))/(ALPET2X(I,J,n)-ALPET1) ( 435) USL(I,J,n)=U(I,J,n,NL1X(I,J,n)) & ( 436) +(U(I,J,n,NL1X(I,J,n)-1)-U(I,J,n,NL1X(I,J,n)))*FACT ( 437) VSL(I,J,n)=V(I,J,n,NL1X(I,J,n))+(V(I,J,n,NL1X(I,J,n)-1) & ( 438) -V(I,J,n,NL1X(I,J,n)))*FACT ( 439) ELSE ( 440) USL(I,J,n)=U(I,J,n,NL1X(I,J,n)) ( 441) VSL(I,J,n)=V(I,J,n,NL1X(I,J,n)) ( 442) ENDIF ( 443) ! ( 444) ! ALPET2 IS MID-LAYER ETA SURFACE JUST BELOW STANDARD PRESSURE ( 445) ! LEVEL AND ALPET1 IS DASHED ETA SURFACE JUST ABOVE. ( 446) ! NOTE THAT IF THE STANDARD PRESSURE SURFACE IS SUBMERGED, THEN ( 447) ! ALPET2 AND ALPET1 ARE THE LOWEST AND 2ND LOWEST MID-LAYER PGF90 (Version 12.8) 08/30/2020 00:27:49 page 11 ( 448) ! ETA SURFACES ABOVE THE TOPOGRAPHY (WITH OLDRD=.TRUE., ZJ). ( 449) ! ( 450) ENDIF ( 451) ! print *,i,j,n,usl(i,j,n),vsl(i,j,n) ( 452) 290 CONTINUE ( 453) ( 454) do j=1,jm ( 455) do i=1,im ( 456) ! print *,i,j,q2sl(i,j,3) ( 457) enddo ( 458) enddo ( 459) ( 460) ! print *,'usl,99,58,6,',usl(99,58,6),usl(99,59,6) ( 461) ! print *,'vsl,99,58,6,',lp,vsl(99,58,6),vsl(99,59,6) ( 462) call bocoh(fsl,im,jm,nm) ( 463) call bocov(usl,vsl,im,jm,nm) ( 464) ! print *,'usl,99,58,6,',usl(99,58,6),usl(99,59,6) ( 465) ! print *,'vsl,99,58,6,',lp,vsl(99,58,6),vsl(99,59,6) ( 466) ( 467) write(1)fsl ( 468) write(1)usl ( 469) write(1)vsl ( 470) write(1)qsl !DRAGAN 23.09.'10 ( 471) write(1)tsl ( 472) !!!avg2017 write(1)q2sl ( 473) ( 474) !!! write(1)w ( 475) !!! write(1)dwdt !non-hydrostatic 2016 ( 476) !!! write(1)z ( 477) ( 478) ( 479) !! write(1)tshltr ( 480) !! write(1)qshltr ( 481) ! write(1)plm ( 482) ( 483) ( 484) 310 continue ( 485) ( 486) close(1) ( 487) ( 488) DEALLOCATE(tsl,qsl,fsl,q2sl,iw) ( 489) ( 490) DEALLOCATE(nl1x,ihold,jhold,nnhold) ( 491) ( 492) DEALLOCATE(alpetux,alpet2x,usl,vsl) ( 493) ( 494) end subroutine eta2p PGF90-W-0103-Type conversion of subscript expression for ul (eta2p.f90: 85)