SUBROUTINE ETA2P(IMOUT,JMOUT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . C SUBPROGRAM: ETA2P VERT INTRP OF ETA TO PRESSURE C PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-21 C C ABSTRACT: C FOR MOST APPLICATIONS THIS ROUTINE IS THE WORKHORSE C OF THE POST PROCESSOR. IN A NUTSHELL IT INTERPOLATES C DATA FROM ETA TO PRESSURE SURFACES. IT ORIGINATED C FROM THE VERTICAL INTERPOLATION CODE IN THE OLD ETA C POST PROCESSOR SUBROUTINE OUTMAP. C . C C PROGRAM HISTORY LOG: C 92-12-21 RUSS TREADON C 96-03-21 GEOFF MANIKIN - ADDED CLOUD ICE ON P C 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D C 98-07-17 MIKE BALDWIN - REMOVED LABL84 C 98-08-18 T BLACK - REMOVED MOST 3-D ARRAYS FROM C COMMON BLOCK JIMA C 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE C 00-01-04 JIM TUCCILLO - MPI VERSION C C USAGE: CALL ETA2P(IMOUT,JMOUT) C INPUT ARGUMENT LIST: C IMOUT - FIRST DIMENSION OF OUTPUT GRID C JMOUT - SECOND DIMENSION OF OUTPUT GRID C C OUTPUT ARGUMENT LIST: C NONE C C OUTPUT FILES: C NONE C C SUBPROGRAMS CALLED: C UTILITIES: C SCLFLD - SCALE ARRAY ELEMENTS BY CONSTANT. C E2OUT - E-GRID TO OUTPUT GRID INTERPOLATION/SMOOTHING. C OUTPUT - POST ARRAY TO OUTPUT FILE. C CALPOT2 - COMPUTE POTENTIAL TEMPERATURE. C CALRH2 - COMPUTE RELATIVE HUMIDITY. C CALDWP2 - COMPUTE DEWPOINT TEMPERATURE. C BOUND - BOUND ARRAY ELEMENTS BETWEEN LOWER AND UPPER LIMITS. C CALMCVG - COMPUTE MOISTURE CONVERGENCE. C CALVOR - COMPUTE ABSOLUTE VORTICITY. C CALSTRM - COMPUTE GEOSTROPHIC STREAMFUNCTION. C C LIBRARY: C COMMON - OMGAOT C LOOPS C MASKS C MAPOT C VRBLS C PVRBLS C RQSTFLD C EXTRA C CLDWTR C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE : IBM SP C$$$ C C C C INCLUDE ETA MODEL DIMENSIONS. SET/DERIVE OTHER PARAMETERS. C GAMMA AND RGAMOG ARE USED IN THE EXTRAPOLATION OF VIRTUAL C TEMPERATURES BEYOND THE UPPER OF LOWER LIMITS OF ETA DATA. C INCLUDE "parmeta" INCLUDE "parmout" INCLUDE "params" C PARAMETER (GAMMA=6.5E-3,RGAMOG=RD*GAMMA/G) C C DECLARE VARIABLES. C LOGICAL RUN,FIRST,RESTRT,SIGMA,OLDRD,STDRD LOGICAL IOOMG,IOALL REAL OSL(IM,JM),USL(IM,JM),VSL(IM,JM) REAL PRSI(IM,JM),QCSL(IM,JM),Q2SL(IM,JM) REAL ICE(IM,JM),IW(IM,JM,LM),IWU,IWL REAL EGRID1(IM,JM),EGRID2(IM,JM) REAL GRID1(IMOUT,JMOUT),GRID2(IMOUT,JMOUT) C C INCLUDE COMMON BLOCKS. INCLUDE "CTLBLK.comm" INCLUDE "OMGAOT.comm" INCLUDE "LOOPS.comm" INCLUDE "MASKS.comm" INCLUDE "MAPOT.comm" INCLUDE "VRBLS.comm" INCLUDE "PVRBLS.comm" INCLUDE "RQSTFLD.comm" INCLUDE "EXTRA.comm" INCLUDE "CLDWTR.comm" INCLUDE "E2PFLG.comm" C COMMON/JIMA/NL1X(IM,JM),ALPETUX(IM,JM),ALPET2X(IM,JM) C C****************************************************************************** C C START ETA2P. C C SET TOTAL NUMBER OF POINTS ON OUTPUT GRID. C C--------------------------------------------------------------- C C *** PART I *** C C VERTICAL INTERPOLATION OF EVERYTHING ELSE. EXECUTE ONLY C IF THERE'S SOMETHING WE WANT. C IF((IGET(012).GT.0).OR.(IGET(013).GT.0).OR. X (IGET(014).GT.0).OR.(IGET(015).GT.0).OR. X (IGET(016).GT.0).OR.(IGET(017).GT.0).OR. X (IGET(018).GT.0).OR.(IGET(019).GT.0).OR. X (IGET(020).GT.0).OR.(IGET(030).GT.0).OR. X (IGET(021).GT.0).OR.(IGET(022).GT.0).OR. X (IGET(153).GT.0).OR.(IGET(166).GT.0))THEN C C SET UP UTIM FOR THIS TIME STEP C UTIM=1. CLIMIT =1.0E-20 C DO 975 L=1,LM IF(L.EQ.1)THEN !$omp parallel do DO J=JSTA,JEND DO I=1,IM IW(I,J,L)=0. ENDDO ENDDO GO TO 975 ENDIF C !$omp parallel do !$omp& private(cwmkl,fiq,hh,lml,pp,qi,qkl,qw,tkl,tmt0,tmt15,u00kl) DO 970 J=JSTA,JEND DO 970 I=1,IM LML=LM-LMH(I,J) HH=HTM(I,J,L)*HBM2(I,J) TKL=T(I,J,L) QKL=Q(I,J,L) CWMKL=CWM(I,J,L) TMT0=(TKL-273.16)*HH TMT15=AMIN1(TMT0,-15.)*HH PP=PDSL(I,J)*AETA(L)+PT QW=HH*PQ0/PP*EXP(HH*A2*(TKL-A3)/(TKL-A4)) QI=QW*(1.+0.01*AMIN1(TMT0,0.)) U00KL=U00(I,J)+UL(L+LML)*(0.95-U00(I,J))*UTIM C IF(TMT0.LT.-15.0)THEN FIQ=QKL-U00KL*QI IF(FIQ.GT.D00.OR.CWMKL.GT.CLIMIT) THEN IW(I,J,L)=1. ELSE IW(I,J,L)=0. ENDIF ENDIF C IF(TMT0.GE.0.0)IW(I,J,L)=0. IF(TMT0.LT.0.0.AND.TMT0.GE.-15.0)THEN IW(I,J,L)=0. IF(IW(I,J,L-1).EQ.1.0.AND.CWMKL.GT.CLIMIT)IW(I,J,L)=1. ENDIF 970 CONTINUE 975 CONTINUE C C C VERTICAL INTERPOLATION OF GEOPOTENTIAL, SPECIFIC HUMIDITY, C AND TEMPERATURE. START AT THE UPPERMOST TARGET PRESSURE LEVEL. C ALPTH = ALOG(1.E5) DO 310 L=1,LSL C C c IF(IOALL)GO TO 225 C TRF=H2*ALSL(L) C C LOOP OVER HORIZONTAL GRID. C !$omp parallel do !$omp& private(lma,lmap1,ppdsl) DO 180 J=JSTA,JEND DO 180 I=1,IM LMA=LM CX IF(OLDRD)LMA=LMH(I,J) LMAP1=LMA+1 C C SET PRESSURE DEPTH IN THIS COLUMN. C PPDSL=PDSL(I,J) C C LOCATE VERTICAL INDEX OF ETA INTERFACE PRESSURES BOUNDING C THE STANDARD PRESSURE LEVEL TO WHICH WE'RE INTERPOLATING. C DO 170 IL=2,LMAP1 IF((ALSL(L)-ALPINT(I,J,IL)).GT.D00)GO TO 170 NL1X(I,J)=IL GO TO 180 170 CONTINUE NL1X(I,J)=LMAP1 180 CONTINUE !$omp parallel do !$omp& private(ahf,ahfo,ahfq,ahfq2,ahfqc,ahfqi,ai,b,bi,bom, !$omp& bq,bq2,bqc,bqc_2,bqi_2,bqi,fac,gmiw,gmiw_2,iwl,iwu, !$omp& lma,lmap1,pl,pnl1,pu,q2a,q2b,qabv,qi,qint,ql, !$omp& qsat,qu,qw,rhu,tabv,tblo,tl,tmt0,tmt15,tu, !$omp& tvrabv,tvrblo,tvrl,tvru,zl,zu) DO 220 J=JSTA,JEND DO 220 I=1,IM LMA =LM LMAP1=LMA+1 IF((TRF-ALPINT(I,J,NL1X(I,J)) 1 -ALPINT(I,J,NL1X(I,J)-1)).LE.D00) 2 NL1X(I,J)=NL1X(I,J)-1 PNL1=PINT(I,J,NL1X(I,J)) C C BRANCH TO APPROPRIATE BLOCK TO COMPUTE COEFFICIENTS. C IF(NL1X(I,J).EQ.1)THEN PU=PINT(I,J,2) ZU=ZINT(I,J,2) TU=D50*(T(I,J,1)+T(I,J,2)) QU=D50*(Q(I,J,1)+Q(I,J,2)) C IWU=D50*(IW(I,J,1)+IW(I,J,2)) TMT0=TU-273.16 TMT15=AMIN1(TMT0,-15.) AI=0.008855 BI=1. IF(TMT0.LT.-20.)THEN AI=0.007225 BI=0.9674 ENDIF QW=PQ0/PU 1 *EXP(A2*(TU-A3)/(TU-A4)) QI=QW*(BI+AI*AMIN1(TMT0,0.)) QINT=QW*(1.-0.00032*TMT15*(TMT15+15.)) IF(TMT0.LT.-15.)THEN QSAT=QI ELSEIF(TMT0.GE.0.)THEN QSAT=QINT ELSE IF(IWU.GT.0.0) THEN QSAT=QI ELSE QSAT=QINT ENDIF ENDIF CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT C DELETE THIS LINE TO SWITCH BACK TO RH VS ICE QSAT=QW CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT RHU =QU/QSAT C IF(RHU.GT.H1)THEN RHU=H1 QU =RHU*QSAT ENDIF C IF(RHU.LT.D01)THEN RHU=D01 QU =RHU*QSAT ENDIF C TVRU=TU*(H1+D608*QU) TVRABV=TVRU*(SPL(L)/PU)**RGAMOG TABV=TVRABV/(H1+D608*QU) C C TMT0=TABV-273.16 TMT15=AMIN1(TMT0,-15.) AI=0.008855 BI=1. IF(TMT0.LT.-20.)THEN AI=0.007225 BI=0.9674 ENDIF QW=PQ0/SPL(L) 1 *EXP(A2*(TABV-A3)/(TABV-A4)) QI=QW*(BI+AI*AMIN1(TMT0,0.)) QINT=QW*(1.-0.00032*TMT15*(TMT15+15.)) IF(TMT0.LT.-15.)THEN QSAT=QI ELSEIF(TMT0.GE.0.)THEN QSAT=QINT ELSE IF(IWU.GT.0.0) THEN QSAT=QI ELSE QSAT=QINT ENDIF ENDIF CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT C DELETE THIS LINE TO SWITCH BACK TO RH VS ICE QSAT=QW CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT QABV =RHU*QSAT QABV =AMAX1(H1M12,QABV) B =TABV BQ =QABV BOM =OMGA(I,J,1) GMIW =IW(I,J,1) BQC =(1.-GMIW)*CWM(I,J,1) BQI =GMIW*CWM(I,J,1) Q2A =D50*(Q2(I,J,1)+Q2(I,J,2)) BQ2 =Q2A AHF =D00 AHFQ =D00 AHFO =D00 AHFQC=D00 AHFQI=D00 AHFQ2=D00 FAC =D00 C ELSEIF(NL1X(I,J).EQ.LMAP1)THEN C C EXTRAPOLATION AT LOWER BOUND. THE LOWER BOUND IS C LM IF OLDRD=.FALSE. IF OLDRD=.TRUE. THE LOWER C BOUND IS THE FIRST ATMOSPHERIC ETA LAYER. C PL=PINT(I,J,LMA-1) ZL=ZINT(I,J,LMA-1) TL=D50*(T(I,J,LMA-2)+T(I,J,LMA-1)) QL=D50*(Q(I,J,LMA-2)+Q(I,J,LMA-1)) C IWL=D50*(IW(I,J,LMA-2)+IW(I,J,LMA-1)) TMT0=TL-273.16 TMT15=AMIN1(TMT0,-15.) AI=0.008855 BI=1. IF(TMT0.LT.-20.)THEN AI=0.007225 BI=0.9674 ENDIF QW=PQ0/PL 1 *EXP(A2*(TL-A3)/(TL-A4)) QI=QW*(BI+AI*AMIN1(TMT0,0.)) QINT=QW*(1.-0.00032*TMT15*(TMT15+15.)) IF(TMT0.LT.-15.)THEN QSAT=QI ELSEIF(TMT0.GE.0.)THEN QSAT=QINT ELSE IF(IWL.GT.0.0) THEN QSAT=QI ELSE QSAT=QINT ENDIF ENDIF CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT C DELETE THIS LINE TO SWITCH BACK TO RH VS ICE QSAT=QW CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT RHL=QL/QSAT C IF(RHL.GT.H1)THEN RHL=H1 QL =RHL*QSAT ENDIF C IF(RHL.LT.D01)THEN RHL=D01 QL =RHL*QSAT ENDIF C TVRL =TL*(H1+D608*QL) TVRBLO=TVRL*(SPL(L)/PL)**RGAMOG TBLO =TVRBLO/(H1+D608*QL) C TMT0=TBLO-273.16 TMT15=AMIN1(TMT0,-15.) AI=0.008855 BI=1. IF(TMT0.LT.-20.)THEN AI=0.007225 BI=0.9674 ENDIF QW=PQ0/SPL(L) 1 *EXP(A2*(TBLO-A3)/(TBLO-A4)) QI=QW*(BI+AI*AMIN1(TMT0,0.)) QINT=QW*(1.-0.00032*TMT15*(TMT15+15.)) IF(TMT0.LT.-15.)THEN QSAT=QI ELSEIF(TMT0.GE.0.)THEN QSAT=QINT ELSE IF(IWL.GT.0.0) THEN QSAT=QI ELSE QSAT=QINT ENDIF ENDIF CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT C DELETE THIS LINE TO SWITCH BACK TO RH VS ICE QSAT=QW CMEB 12/22/98 SWITCH TO RH VS WATER NO MATTER WHAT QBLO =RHL*QSAT QBLO =AMAX1(H1M12,QBLO) B =TBLO BQ =QBLO BOM =OMGA(I,J,LMA) GMIW =IW(I,J,LMH(I,J)) BQC =(1.-GMIW)*CWM(I,J,LMH(I,J)) BQI =GMIW*CWM(I,J,LMH(I,J)) Q2A =D50*(Q2(I,J,LMH(I,J)-1)+Q2(I,J,LMH(I,J))) BQ2 =Q2A AHF =D00 AHFQ =D00 AHFO =D00 AHFQC=D00 AHFQI=D00 AHFQ2=D00 FAC =D00 C ELSE C C INTERPOLATION BETWEEN LOWER AND UPPER BOUNDS. C B =T(I,J,NL1X(I,J)) BQ =Q(I,J,NL1X(I,J)) BOM =OMGA(I,J,NL1X(I,J)) GMIW =IW(I,J,NL1X(I,J)) BQC =(1.-GMIW)*CWM(I,J,NL1X(I,J)) BQI =GMIW*CWM(I,J,NL1X(I,J)) GMIW_2=IW(I,J,NL1X(I,J)-1) BQC_2 =(1.-GMIW)*CWM(I,J,NL1X(I,J)-1) BQI_2 =GMIW*CWM(I,J,NL1X(I,J)-1) Q2B =D50*(Q2(I,J,NL1X(I,J)-1)+Q2(I,J,NL1X(I,J))) C IF(NL1X(I,J).GT.2)THEN Q2A=D50*(Q2(I,J,NL1X(I,J)-2)+Q2(I,J,NL1X(I,J)-1)) ELSE Q2A=Q2B ENDIF C BQ2=Q2B*HTM(I,J,NL1X(I,J)) FAC =H2*ALOG(PT+PDSL(I,J)*AETA(NL1X(I,J))) AHF =(B-T(I,J,NL1X(I,J)-1))/ 1 (ALPINT(I,J,NL1X(I,J)+1)-ALPINT(I,J,NL1X(I,J)-1)) AHFQ =(BQ-Q(I,J,NL1X(I,J)-1))/ 1 (ALPINT(I,J,NL1X(I,J)+1)-ALPINT(I,J,NL1X(I,J)-1)) AHFO =(BOM-OMGA(I,J,NL1X(I,J)-1))/ 1 (ALPINT(I,J,NL1X(I,J)+1)-ALPINT(I,J,NL1X(I,J)-1)) AHFQC=(BQC-BQC_2)/ 1 (ALPINT(I,J,NL1X(I,J)+1)-ALPINT(I,J,NL1X(I,J)-1)) AHFQI=(BQI-BQI_2)/ 1 (ALPINT(I,J,NL1X(I,J)+1)-ALPINT(I,J,NL1X(I,J)-1)) AHFQ2=(BQ2-Q2A*HTM(I,J,NL1X(I,J)-1))/ 1 (ALPINT(I,J,NL1X(I,J)+1)-ALPINT(I,J,NL1X(I,J)-1)) ENDIF C TSL(I,J)=B+AHF*(TRF-FAC) QSL(I,J)=BQ+AHFQ*(TRF-FAC) QSL(I,J)=AMAX1(QSL(I,J),H1M12) OSL(I,J)=BOM+AHFO*(TRF-FAC) QCSL(I,J)=BQC+AHFQC*(TRF-FAC) QCSL(I,J)=AMAX1(QCSL(I,J),H1M12) ICE(I,J)=BQI+AHFQI*(TRF-FAC) ICE(I,J)=AMAX1(ICE(I,J),H1M12) Q2SL(I,J)=BQ2+AHFQ2*(TRF-FAC) Q2SL(I,J)=AMAX1(Q2SL(I,J),D00) FSL(I,J)=(PNL1-SPL(L))/(SPL(L)+PNL1) 1 *((ALSL(L)+ALPINT(I,J,NL1X(I,J))-FAC)*AHF+B)*R*H2 2 +ZINT(I,J,NL1X(I,J))*G 220 CONTINUE C C LOAD GEOPOTENTIAL AND TEMPERATURE INTO STANDARD LEVEL C ARRAYS FOR THE NEXT PASS. C 225 CONTINUE C C SAVE 500MB TEMPERATURE FOR LIFTED INDEX. C IF((NINT(SPL(L)).EQ.50000).AND. 1 ((IGET(030).GT.0).OR.(IGET(031).GT.0).OR. 2 (IGET(075).GT.0)))THEN !$omp parallel do DO J=JSTA,JEND DO I=1,IM T500(I,J)=TSL(I,J) ENDDO ENDDO ENDIF C C CALCULATE 1000MB GEOPOTENTIALS CONSISTENT WITH SLP OBTAINED C FROM THE MESINGER OR NWS SHUELL SLP REDUCTION. C IF(NINT(SPL(L)).EQ.100000)THEN C C MESINGER SLP C IF(IGET(023).GT.0)THEN write(6,*) 'have mesinger SLP' !$omp parallel do write(6,*) 'PSLP over domain' do j=jend,jsta,-jend/20 write(6,366) (NINT(PSLP(I,J)/100),I=1,IM,IM/12) enddo 366 format(20(I4,1x)) DO J=JSTA,JEND DO I=1,IM ALPSL=ALOG(PSLP(I,J)) IF(FIS(I,J).GT.H1 .and. PD(I,J) .lt. 97500.)THEN if ((ALPSL-ALOG(PD(I,J)+PT))*(ALPSL-ALPTH) .eq. 0) then write(6,*) 'avoiding divzero in eta2p' FSL(I,J)=0. else FSL(I,J)=FIS(I,J)/(ALPSL-ALOG(PD(I,J)+PT))* 1 (ALPSL-ALPTH) endif ELSE FSL(I,J)=R*T(I,J,LM)*(ALPSL-ALPTH) if (FIS(I,J) .GT. H1) then DIFF=(FSL(I,J)-(FIS(I,J)/(ALPSL-ALOG(PD(I,J)+PT))* + (ALPSL-ALPTH)))*GI if (abs(DIFF) .gt. 4) then write(6,*) 'mod decision at ', I,J, FIS(I,J)*GI write(6,*) 'changed from ', + GI*FIS(I,J)/(ALPSL-ALOG(PD(I,J)+PT))*(ALPSL-ALPTH), + 'to: ', FSL(I,J)*GI, 'diff of ', DIFF endif endif ENDIF Z1000(I,J)=FSL(I,J)*GI ENDDO ENDDO C C NWS SHUELL SLP. NGMSLP2 COMPUTES 1000MB GEOPOTENTIAL. C ELSE !$omp parallel do DO J=JSTA,JEND DO I=1,IM FSL(I,J)=Z1000(I,J)*G ENDDO ENDDO ENDIF ENDIF C C INTERPOLATE WIND COMPONENTS FROM ETA TO PRESSURE. C IF((IGET(018).GT.0).OR.(IGET(019).GT.0).OR. 1 (IGET(021).GT.0).OR.(IGET(085).GT.0))THEN C !$omp parallel do DO J=JSTA,JEND DO I=1,IM USL(I,J)=D00 VSL(I,J)=D00 ENDDO ENDDO C !!$omp parallel do !!$omp& private(alpet2,alpetl,alpetu,lmb,petal,petau) !!$omp& shared (alpet2x,alpetux,nl1x) DO 281 J=JSTA,JEND DO 281 I=1,IM CNOTE CNOTE 29 JANUARY 1993, RUSS TREADON. CNOTE - AS FOR THE OTHER FIELDS WE INTERPOLATE ONLY CNOTE BETWEEN THE FAL AND THE MODEL TOP. BELOW CNOTE SURFACE VALUES ARE FAL VALUES. C LMB = LMV(I,J) C PETAU=PT+PDVP1(I,J)*ETA(1) ALPETU=ALOG(PETAU) DO 280 IL=2,LMB PETAL=PT+PDVP1(I,J)*ETA(IL) c PETAU=PT+PDVP1(I,J)*ETA(IL-1) ALPETL=ALOG(PETAL) c ALPETU=ALOG(PETAU) ALPET2=SQRT(0.5E0*(ALPETL*ALPETL+ALPETU*ALPETU)) C C SEARCH FOR HIGHEST MID-LAYER ETA SURFACE (NOT SUBMERGED) C THAT IS BELOW THE GIVEN STANDARD PRESSURE LEVEL. IF(ALSL(L).LT.ALPET2)THEN NL1X(I,J)=IL-1 ALPETUX(I,J)=ALPETU ALPET2X(I,J)=ALPET2 GO TO 281 ENDIF C If we arent on the last iterate of the 280 loop, reset PETAU and ALPETU if ( il .eq. lmb ) goto 280 PETAU=PETAL ALPETU=ALPETL 280 CONTINUE NL1X(I,J)=LMB+1 ALPETUX(I,J)=ALPETU ALPET2X(I,J)=ALPET2 281 CONTINUE C C BELOW GROUND USE FAL WINDS. C !$omp parallel do !$omp& private(alpet1,alpetl,alpetu,fact,petau) DO 290 J=JSTA,JEND DO 290 I=1,IM IF(NL1X(I,J).GT.LMV(I,J))THEN USL(I,J)=U(I,J,LMV(I,J)) VSL(I,J)=V(I,J,LMV(I,J)) C C IF REQUESTED PRESSURE LEVEL IS NOT BELOW THE LOCAL GROUND C THEN WE HAVE TWO POSSIBILITIES. IF THE REQUESTED PRESSURE C LEVEL IS BETWEEN THE LOCAL SURFACE PRESSURE AND TOP OF C MODEL PRESSURE, VERTICALLY INTERPOLATE BETWEEN NEAREST C BOUNDING ETA LEVELS TO GET THE WIND COMPONENTS. IF THE C REQUESTED PRESSURE LEVEL IS ABOVE THE MODEL TOP, USE C CONSTANT EXTRAPOLATION OF TOP ETA LAYER (L=1) WINDS. C ELSE IF(NL1X(I,J).GT.1)THEN ALPETL=ALPETUX(I,J) PETAU=PT+PDVP1(I,J)*ETA(NL1X(I,J)-1) ALPETU=ALOG(PETAU) ALPET1=SQRT(0.5*(ALPETL*ALPETL+ALPETU*ALPETU)) FACT=(ALPET2X(I,J)-ALSL(L))/(ALPET2X(I,J)-ALPET1) USL(I,J)=U(I,J,NL1X(I,J)) 1 +(U(I,J,NL1X(I,J)-1)-U(I,J,NL1X(I,J)))*FACT VSL(I,J)=V(I,J,NL1X(I,J))+(V(I,J,NL1X(I,J)-1) 1 -V(I,J,NL1X(I,J)))*FACT ELSE USL(I,J)=U(I,J,NL1X(I,J)) VSL(I,J)=V(I,J,NL1X(I,J)) ENDIF C C ALPET2 IS MID-LAYER ETA SURFACE JUST BELOW STANDARD PRESSURE C LEVEL AND ALPET1 IS DASHED ETA SURFACE JUST ABOVE. C NOTE THAT IF THE STANDARD PRESSURE SURFACE IS SUBMERGED, THEN C ALPET2 AND ALPET1 ARE THE LOWEST AND 2ND LOWEST MID-LAYER C ETA SURFACES ABOVE THE TOPOGRAPHY (WITH OLDRD=.TRUE., ZJ). C ENDIF 290 CONTINUE ENDIF C C C *** PART II *** C C INTERPOLATE/OUTPUT SELECTED FIELDS. C C GEOPOTENTIAL (SCALE BY GI) IF (IGET(012).GT.0) THEN IF (LVLS(L,IGET(012)).GT.0) THEN !$omp parallel do DO J=JSTA,JEND DO I=1,IM EGRID1(I,J)=FSL(I,J)*GI ENDDO ENDDO C CALL E2OUT(012,000,EGRID1,EGRID2,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(012),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C TEMPERATURE. IF (IGET(013).GT.0) THEN IF (LVLS(L,IGET(013)).GT.0) THEN CALL E2OUT(013,000,TSL,EGRID2,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(013),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C POTENTIAL TEMPERATURE. IF (IGET(014).GT.0) THEN IF (LVLS(L,IGET(014)).GT.0) THEN !$omp parallel do DO J=JSTA,JEND DO I=1,IM EGRID2(I,J)=SPL(L) ENDDO ENDDO CALL CALPOT2(EGRID2,TSL,EGRID1,IM,JM) CALL E2OUT(014,000,EGRID1,EGRID2,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(014),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C RELATIVE HUMIDITY. IF (IGET(017).GT.0) THEN IF (LVLS(L,IGET(017)).GT.0) THEN !$omp parallel do DO J=JSTA,JEND DO I=1,IM EGRID2(I,J)=SPL(L) ENDDO ENDDO CALL CALRH2(EGRID2,TSL,QSL,ICE,EGRID1,IM,JM) CALL E2OUT(017,000,EGRID1,EGRID2,GRID1,GRID2,IMOUT,JMOUT) CALL SCLFLD(GRID1,H100,IMOUT,JMOUT) CALL BOUND(GRID1,H1,H100,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(017),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C DEWPOINT TEMPERATURE. IF (IGET(015).GT.0) THEN IF (LVLS(L,IGET(015)).GT.0) THEN !$omp parallel do DO J=JSTA,JEND DO I=1,IM EGRID2(I,J)=SPL(L) ENDDO ENDDO CALL CALDWP2(EGRID2,QSL,EGRID1,TSL) CALL E2OUT(015,000,EGRID1,EGRID2,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(015),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C SPECIFIC HUMIDITY. IF (IGET(016).GT.0) THEN IF (LVLS(L,IGET(016)).GT.0) THEN CALL E2OUT(016,000,QSL,EGRID2,GRID1,GRID2,IMOUT,JMOUT) CALL BOUND(GRID1,H1M12,H99999,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(016),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C OMEGA IF (IGET(020).GT.0) THEN IF (LVLS(L,IGET(020)).GT.0) THEN CALL E2OUT(020,000,OSL,EGRID2,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(020),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C MOISTURE CONVERGENCE. IF (IGET(085).GT.0) THEN IF (LVLS(L,IGET(085)).GT.0) THEN CALL CALMCVG(QSL,USL,VSL,-1,EGRID1) CALL E2OUT(085,000,EGRID1,EGRID2, X GRID1,GRID2,IMOUT,JMOUT) C CONVERT TO DIVERGENCE FOR GRIB UNITS CALL SCLFLD(GRID1,-1.0,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(085),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C U AND/OR V WIND. IF (IGET(018).GT.0.OR.IGET(019).GT.0) THEN IF (LVLS(L,IGET(018)).GT.0.OR.LVLS(L,IGET(019)).GT.0) THEN CALL E2OUT(018,019,USL,VSL,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 IF (IGET(018).GT.0)then CALL OUTPUT(IOUTYP,IGET(018),L,GRID1,IMOUT,JMOUT) endif ID(1:25)=0 IF (IGET(019).GT.0) X CALL OUTPUT(IOUTYP,IGET(019),L,GRID2,IMOUT,JMOUT) ENDIF ENDIF C C ABSOLUTE VORTICITY. IF (IGET(021).GT.0) THEN IF (LVLS(L,IGET(021)).GT.0) THEN CALL CALVOR(USL,VSL,EGRID1) CALL E2OUT(021,000,EGRID1,EGRID2,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(021),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C GEOSTROPHIC STREAMFUNCTION. IF (IGET(086).GT.0) THEN IF (LVLS(L,IGET(086)).GT.0) THEN !$omp parallel do DO J=JSTA,JEND DO I=1,IM EGRID2(I,J)=FSL(I,J)*GI ENDDO ENDDO CALL CALSTRM(EGRID2,EGRID1) CALL E2OUT(086,000,EGRID1,EGRID2,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(086),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C TURBULENT KINETIC ENERGY. IF (IGET(022).GT.0) THEN IF (LVLS(L,IGET(022)).GT.0) THEN CALL E2OUT(022,000,Q2SL,EGRID2,GRID1,GRID2,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(022),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C TOTAL CLOUD WATER. IF (IGET(153).GT.0) THEN IF (LVLS(L,IGET(153)).GT.0) THEN CALL E2OUT(153,000,QCSL,EGRID2,GRID1,GRID2,IMOUT,JMOUT) CALL BOUND(GRID1,H1M12,H99999,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(153),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C TOTAL CLOUD ICE IF (IGET(166).GT.0) THEN IF (LVLS(L,IGET(166)).GT.0) THEN CALL E2OUT(166,000,ICE,EGRID2,GRID1,GRID2,IMOUT,JMOUT) CALL BOUND(GRID1,H1M12,H99999,IMOUT,JMOUT) ID(1:25)=0 CALL OUTPUT(IOUTYP,IGET(166),L,GRID1,IMOUT,JMOUT) ENDIF ENDIF C C END OF MAIN VERTICAL LOOP. C 310 CONTINUE IOALL=.TRUE. C C ENDIF FOR IF TEST SEEING IF WE WANT ANY OTHER VARIABLES ENDIF C C END OF ROUTINE. C RETURN END