SUBROUTINE PHASE CC************************************************************************ CC * CC THIS SUBROUTINE OBTAINS THE BASIC FLOW FIELD FOR U,V,T,R,P-STAR * CC FIELD FOR EACH NEST. THE VALUE IS FIRST OBTAINED AT THE * CC COARSE RESOLUTION. VALUES FOR THE FINER MESHES ARE THEN * CC OBTAINED BY INTERPOLATION * CC CC CC************************************************************************ PARAMETER (IMX=150, JMX=150, KMAX=42,LGI=27,KMAXP=KMAX+1) parameter (nwat = 6, nwat3 = nwat + 3, nvar=nwat3) PARAMETER (N = 40, IBLKMX=LGI*IMX+nwat3*KMAX*IMX, ND = 20, * JBLKMX = IMX + KMAX*IMX*14, NNST = 3, NGDFD = 19) PARAMETER (IXM = 100, IYM = 100 , KMAXM=KMAX-1, * NXM = 100, NYM = 100 , NH = 25) CC CC PARAMETER (IMXX=250,nnmx=24) CC CC IMXX IS THE IMX VALUE USED IN DMENSION OF THE INTEGRATION DOMAINS CC CC************************************************************************ CC include 'CONMLEV.h' COMMON /POSIT/ XOLD,YOLD,XCORN,YCORN,RO,XV,YV,ROMM,TSIZE COMMON /BACK/ TKBK COMMON /SURFC/ TSMEAN,WTMEAN,WSIN COMMON /TANG/ VT(KMAX,IMXX),TBAR(KMAX),RBAR(KMAX),PBAR,FCOR COMMON /FILC/ TYP1C(IMX,LGI),TYP2C(KMAX,IMX,nwat3) COMMON /GDINF/ NGD,NGR,NTR,DT,JS,JN,IE,IW,IIMAX,IMAX,JJMAX, * JMAX,NSTFLG,ICX,ICY,IHX,IHY,DFTX,DFTY DIMENSION U(IMX,JMX,KMAX),V(IMX,JMX,KMAX), * T(IMX,JMX,KMAX),R(IMX,JMX,KMAX), * YTU(KMAX,JMX,NH),YTV(KMAX,JMX,NH),YTT(KMAX,JMX,NH), * XTU(KMAX,IMX,NH),XTV(KMAX,IMX,NH),XTT(KMAX,IMX,NH), * YTR(KMAX,JMX,NH),XTR(KMAX,IMX,NH),PSTAR(IMX,JMX) DIMENSION ZNOT(IMX,JMX),TSTR(IMX,JMX),WET(IMX,JMX),ro(nnmx) DIMENSION TDINF(19),FILEPC(IBLKMX),XPS(IMX,NH),YPS(JMX,NH) DIMENSION CPA(IMX,JMX,KMAX,4), TK(NH) , AMPF(25) EQUIVALENCE (FILEPC(1),TYP1C(1,1)),(U(1,1,1),CPA(1,1,1,1)) CHARACTER*12 IBLOCK CC REWIND 9 CC C C ires is the resolution in degrees devided by one................. C ires = 2 CC iewst = ifix(XV - XCORN) nosst = ifix(YV - YCORN) ICOR = ires * iewst + 1 JCOR = ires * nosst + 1 WRITE(6,3333)ICOR,JCOR 3333 FORMAT(2X,'I-J COOR:',2I5) CC CC PI180 = 4.*ATAN(1.0)/180. COSFT = COS(YOLD*PI180) CC CC CC DO 3346 ID =1 , 4 DO 3346 K = 1 , KMAX DO 3346 J = 1 , JMX DO 3346 I = 1 , IMX CPA(I,J,K,ID) = 0.0 3346 CONTINUE CC CC READ(9)NSTEP,NNEST CC CC TN = FLOAT(N) CCC PI = 4.*ATAN(1.0) COSF = COS(2.*PI/TN) - 1. ISMTH = 0 CC IF(TSIZE.EQ.1.)THEN NTY = 8 WRITE(6,3404) 3404 FORMAT(2X,'THE STORM SIZE OF THE GLOBAL VORTEX IS SMALL SIZE') ENDIF CC IF(TSIZE.EQ.2.)THEN NTY = 11 WRITE(6,3405) 3405 FORMAT(2X,'THE STORM SIZE OF THE GLOBAL VORTEX IS NORMAL SIZE') ENDIF CC IF(TSIZE.EQ.3.)THEN NTY = 17 WRITE(6,3406) 3406 FORMAT(2X,'THE STORM SIZE OF THE GLOBAL VORTEX IS HUGE ') ENDIF CC IF(TSIZE.EQ.4.)THEN NTY = 21 WRITE(6,3407) 3407 FORMAT(2X,'THE STORM SIZE OF THE GLOBAL VORTEX IS 2 NEST') ENDIF CC CC CHG = 0.0 KT = 0 DO 802 KTY = 1 , NTY CCC CC IF(TSIZE.EQ.1)THEN IF(KTY.EQ.4.OR.KTY.EQ.8)CHG = 1.0 ENDIF CC CC IF(TSIZE.EQ.2)THEN IF(KTY.EQ.4.OR.KTY.EQ.8.OR.KTY.GE.11)CHG = 1.0 ENDIF CC CC CC IF(TSIZE.EQ.3)THEN IF(KTY.EQ.4.OR.KTY.EQ.8.OR.KTY.EQ.12.OR.KTY.GE.14.)CHG = 1.0 ENDIF C IF(TSIZE.EQ.4)THEN CCC IF(KTY.EQ.4.OR.KTY.EQ.8.OR.KTY.EQ.12.OR.KTY.GE.15.)CHG = 1.0 IF(KTY.EQ.4.OR.KTY.EQ.8.OR.KTY.EQ.12.OR.KTY.GE.14.)CHG = 1.0 ENDIF C IF(CHG.EQ.0)KT = KT + 1 IF(CHG.EQ.1.0)TK(KTY) = .25 IF(CHG.EQ.1.0)GO TO 801 FACT = 2.0*PI/(FLOAT(KT) + 1.0) TK(KTY) = -.5/(COS(FACT) - 1.0) DO 679 NA = 2 , 25 AMPF(NA) = 1 + 2.*TK(KTY)*(COS(2.*PI/FLOAT(NA)) - 1.0) 679 CONTINUE CCC CCC 801 CONTINUE CHG = 0.0 802 CONTINUE CCC CC IF(ISMTH.EQ.1)THEN NTYM = NTY - 1 TFF = 1.0 DO 61 K = 1 , NTYM TFF = TFF*(1. + 2.*TK(K)*COSF) 61 CONTINUE TFR = 1./TFF TK(NTY) = (TFR - 1.0)/(2.*COSF) ENDIF CC CC CC DO 610 NZ = 2 , 40 AMP = 1.0 TNN = FLOAT(NZ) CKG = 0.0 IF(NZ.GT.9)CKG = 1.0 DO 617 KT = 1 , NTY AMP1 = (1. + 2*TK(KT)*(COS(2.*PI/TNN)-1.0)) IF(CKG.EQ.0.0)GO TO 619 AMP = AMP1*AMP 619 IF(ABS(AMP1).LT..01)CKG = 1.0 617 CONTINUE 610 CONTINUE CC CC CCC CC READ(9)NGD,NGR,NTR,DT,JS,JN,IE,IW,IIMAX,IMAX,JJMAX,JMAX, * NSTFLG,ICKX,ICKY,IHX,IHY,DFTX,DFTY CCC CC IMAXM = IMAX - 1 JMAXM = JMAX - 1 DO 15 J = 1 , JMAX CC READ(9)DIGGG READ(9)(FILEPC(I),I=1,IBLKMX) CC DO 455 I = 1 , IMX CC ZNOT(I,J) = TYP1C(I,15) CC TSTR(I,J) = TYP1C(I,10) WET(I,J) = TYP1C(I,16) 455 CONTINUE CC TLAP=6.1/(980.*1.0E5) DO 2212 I=1,IMX TTTT=ALOG(1.0+TLAP*TYP1C(I,11)/TYP2C(KMAX,I,3) ) EPSI=TTTT/(RGAS*TLAP) TYP1C(I,LGI)=TYP1C(I,LGI)*EXP(EPSI) 2212 CONTINUE CC DO 588 NN = 1 , NTY XPS(1,NN) = TYP1C(1,LGI) XPS(IMAX,NN) = TYP1C(IMAX,LGI) 588 CONTINUE CC CC DO 58 NN = 1 , NTY DO 58 K = 1 , KMAX XTU(K,1,NN) = TYP2C(K,1,1) XTU(K,IMAX,NN) = TYP2C(K,IMAX,1) XTV(K,1,NN) = TYP2C(K,1,2) XTV(K,IMAX,NN) = TYP2C(K,IMAX,2) XTT(K,1,NN) = TYP2C(K,1,3) XTT(K,IMAX,NN) = TYP2C(K,IMAX,3) XTR(K,1,NN) = TYP2C(K,1,4) XTR(K,IMAX,NN) = TYP2C(K,IMAX,4) 58 CONTINUE CC DO 660 I = 2 , IMAXM XPS(I,1) = TYP1C(I,LGI) + TK(1)*(TYP1C(I-1,LGI) + * TYP1C(I+1,LGI) - 2.*TYP1C(I,LGI)) 660 CONTINUE CC CC DO 60 I = 2 , IMAXM DO 60 K = 1 , KMAX XTU(K,I,1) = TYP2C(K,I,1) + TK(1)*(TYP2C(K,I-1,1) + * TYP2C(K,I+1,1) - 2.*TYP2C(K,I,1)) XTV(K,I,1) = TYP2C(K,I,2) + TK(1)*(TYP2C(K,I-1,2) + * TYP2C(K,I+1,2) - 2.*TYP2C(K,I,2)) XTT(K,I,1) = TYP2C(K,I,3) + TK(1)*(TYP2C(K,I-1,3) + * TYP2C(K,I+1,3) - 2.*TYP2C(K,I,3)) XTR(K,I,1) = TYP2C(K,I,4) + TK(1)*(TYP2C(K,I-1,4) + * TYP2C(K,I+1,4) - 2.*TYP2C(K,I,4)) 60 CONTINUE CC DO 650 NN = 2 , NTY DO 620 I = 2 , IMAXM XPS(I,NN) = XPS(I,NN-1) + TK(NN)*(XPS(I-1,NN-1) + * XPS(I+1,NN-1) - 2.*XPS(I,NN-1)) 620 CONTINUE 650 CONTINUE CC DO 65 NN = 2 , NTY DO 62 I = 2 , IMAXM DO 62 K = 1 , KMAX XTU(K,I,NN) = XTU(K,I,NN-1) + TK(NN)*(XTU(K,I-1,NN-1) + *XTU(K,I+1,NN-1) - 2.*XTU(K,I,NN-1)) XTV(K,I,NN) = XTV(K,I,NN-1) + TK(NN)*(XTV(K,I-1,NN-1) + *XTV(K,I+1,NN-1) - 2.*XTV(K,I,NN-1)) XTT(K,I,NN) = XTT(K,I,NN-1) + TK(NN)*(XTT(K,I-1,NN-1) + *XTT(K,I+1,NN-1) - 2.*XTT(K,I,NN-1)) XTR(K,I,NN) = XTR(K,I,NN-1) + TK(NN)*(XTR(K,I-1,NN-1) + *XTR(K,I+1,NN-1) - 2.*XTR(K,I,NN-1)) 62 CONTINUE 65 CONTINUE CC DO 70 K = 1 , KMAX DO 70 I = 1 , IMAX U(I,J,K) = XTU(K,I,NTY) V(I,J,K) = XTV(K,I,NTY) T(I,J,K) = XTT(K,I,NTY) R(I,J,K) = XTR(K,I,NTY) PSTAR(I,J) = XPS(I,NTY) 70 CONTINUE CC C 15 CONTINUE CC CC CC******************************************************************** CC CC CC NOW DO THE SMOOTHING IN THE MERIDIONAL DIRECTION CC CC IMAXM = IMAX - 1 JMAXM = JMAX - 1 CC DO 85 I = 1 , IMAX DO 80 NN = 1 , NTY YPS(1,NN) = PSTAR(I,1) YPS(JMAX,NN) = PSTAR(I,JMAX) DO 80 K = 1 , KMAX YTU(K,1,NN) = U(I,1,K) YTU(K,JMAX,NN) = U(I,JMAX,K) YTV(K,1,NN) = V(I,1,K) YTV(K,JMAX,NN) = V(I,JMAX,K) YTT(K,1,NN) = T(I,1,K) YTT(K,JMAX,NN) = T(I,JMAX,K) YTR(K,1,NN) = R(I,1,K) YTR(K,JMAX,NN) = R(I,JMAX,K) 80 CONTINUE CC DO 900 J = 2 , JMAXM YPS(J,1) = PSTAR(I,J) + TK(1)*(PSTAR(I,J-1) + PSTAR(I,J+1) * -2.*PSTAR(I,J)) 900 CONTINUE CC CC CC DO 90 J = 2 , JMAXM DO 90 K = 1 , KMAX YTU(K,J,1) = U(I,J,K) + TK(1)*(U(I,J-1,K) + U(I,J+1,K) * -2.*U(I,J,K)) YTV(K,J,1) = V(I,J,K) + TK(1)*(V(I,J-1,K) + V(I,J+1,K) * -2.*V(I,J,K)) YTT(K,J,1) = T(I,J,K) + TK(1)*(T(I,J-1,K) + T(I,J+1,K) * -2.*T(I,J,K)) YTR(K,J,1) = R(I,J,K) + TK(1)*(R(I,J-1,K) + R(I,J+1,K) * -2.*R(I,J,K)) 90 CONTINUE CC DO 950 NN = 2 , NTY DO 950 J = 2 , JMAXM YPS(J,NN) = YPS(J,NN-1) + TK(NN)*(YPS(J-1,NN-1) + * YPS(J+1,NN-1) - 2.*YPS(J,NN-1)) 950 CONTINUE CC CC DO 95 NN = 2 , NTY DO 95 J = 2 , JMAXM DO 95 K = 1 , KMAX YTU(K,J,NN) = YTU(K,J,NN-1) + TK(NN)*(YTU(K,J-1,NN-1) + * YTU(K,J+1,NN-1) - 2.*YTU(K,J,NN-1)) YTV(K,J,NN) = YTV(K,J,NN-1) + TK(NN)*(YTV(K,J-1,NN-1) + * YTV(K,J+1,NN-1) - 2.*YTV(K,J,NN-1)) YTT(K,J,NN) = YTT(K,J,NN-1) + TK(NN)*(YTT(K,J-1,NN-1) + * YTT(K,J+1,NN-1) - 2.*YTT(K,J,NN-1)) YTR(K,J,NN) = YTR(K,J,NN-1) + TK(NN)*(YTR(K,J-1,NN-1) + * YTR(K,J+1,NN-1) - 2.*YTR(K,J,NN-1)) 95 CONTINUE CC DO 99 J = 1 , JMAX PSTAR(I,J) = YPS(J,NTY) DO 99 K = 1 , KMAX U(I,J,K) = YTU(K,J,NTY) V(I,J,K) = YTV(K,J,NTY) T(I,J,K) = YTT(K,J,NTY) R(I,J,K) = YTR(K,J,NTY) 99 CONTINUE CC 85 CONTINUE CC CC cc CC U(I,J,K) IS THE SMOOTHED U COMPONENT OF THE BASIC FIELD OF NEST 1 CC V(I,J,K) IS THE SMOOTHED V COMPONENT OF THE BASIC FIELD OF NEST 1 CC T(I,J,K) IS THE SMOOTHED T COMPONENT OF THE BASIC FIELD OF NEST 1 CC R(I,J,K) IS THE SMOOTHED R COMPONENT OF THE BASIC FIELD OF NEST 1 CC CC**************************************************************** CC CCXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CC TSMEAN = 0.0 WTMEAN = 0.0 TCNT = 0.0 ZNMEAN = 0.0 CC ICM = ICOR-4 ICP = ICOR+4 JCM = JCOR-4 JCP = JCOR+4 DO 777 J = JCM,JCP DO 777 I = ICM,ICP C IF(ZNOT(I,J).LT.0.0)THEN TCNT = TCNT + 1.0 TSMEAN = TSMEAN + TSTR(I,J) ENDIF C 777 CONTINUE TSMEAN = TSMEAN/TCNT CC IF(TSMEAN.GT.303.)THEN TSMEAN = .5*(TSMEAN + 303.) ENDIF CC ICM = ICOR-1 ICP = ICOR+1 JCM = JCOR-1 JCP = JCOR+1 DO 778 J = JCM,JCP DO 778 I = ICM,ICP WTMEAN = WTMEAN + WET(I,J)/9. 778 CONTINUE CC CCCCCC WSIN = WET(ICOR,JCOR) FFF = .5 WTMEAN = (1.-FFF)*WET(ICOR,JCOR) + WTMEAN*FFF CC CCXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CC WRITE(6,3044)TSMEAN,WTMEAN,WSIN 3044 FORMAT(2X,'TSTAR: ',E12.6,' WET: ',2E12.6) CC CCCCC WTMEAN = 1.0 CC PBAR = PSTAR(ICOR,JCOR) DO 1400 K = 1 , KMAX TBAR(K) = T(ICOR,JCOR,K) RBAR(K) = R(ICOR,JCOR,K) 1400 CONTINUE CC WRITE(6,2307)PBAR 2307 FORMAT(2X,'PBAR:',10E11.5) WRITE(6,2305)(TBAR(K), K = 1 , KMAX) WRITE(6,2306)(RBAR(K), K = 1 , KMAX) 2305 FORMAT(2X,'TBAR:',(/,2X,10E11.5)) 2306 FORMAT(2X,'RBAR:',(/,2X,10E11.5)) CC cccc WRITE(51)PBAR cccc WRITE(51)(TBAR(K), K = 1 , KMAX) cccc WRITE(51)(RBAR(K), K = 1 , KMAX) C SLPE = 1.0E4 TKBB = 1.0E4 TDIFF = TSMEAN - TBAR(KMAX) IF(TDIFF .GT. 1.0)THEN TKCOR = TDIFF - 1.0 TKBK = TKBB + SLPE*TKCOR ELSE TKBK = TKBB ENDIF C CCCC TKBK = 1.0E4 C WRITE(6,3416)TKBK 3416 FORMAT(2X,'THIS IS THE MIXING COEF: ',E12.6) WRITE(6,3419)TDIFF 3419 FORMAT(2X,'THIS IS THE TEMPERATURE DIFFERENCE: ',F6.2) REWIND 9 RETURN END