SUBROUTINE GLOOP(TPS) COMMON IDATE(4), * GESHEM( 50 , 42 ),TSEA( 50 , 42 ),GRGRID( 50 , 42 ) COMMON DPDPHI( 306 ),DPDLAM( 289 ),RELVOR( 7 ),ABSVOR( 7 ), 1 Q( 289 ), TE( 289 , 7 ), DI( 289 , 7 ), ZE( 289 , 7 ), 2 Z( 289 ), Y( 289 , 7 ), X( 289 , 7 ), W( 289 , 7 ), 3 QM( 289 ),TEM( 289 , 7 ),DIM( 289 , 7 ),ZEM( 289 , 7 ), 5 GZ( 289 ), RQ( 289 , 6 ), RM( 289 , 6 ), RT( 289 , 6 ) COMPLEX GZ,Q,TE,DI,ZE,Z,Y,X,W,QM,TEM,DIM,ZEM,RELVOR, 1DPDLAM,DPDPHI,ABSVOR,RQ,RM,RT COMMON * PS( 50 ), DPHI( 50 ), DLAM( 50 ), * QF( 50 ),DPHIF( 50 ),DLAMF( 50 ), * EF( 50 , 7 ), EEF( 50 , 7 ), CG( 50 , 7 ), * TF( 50 , 7 ), TEF( 50 , 7 ),TAU( 50 , 7 ), * AF( 50 , 7 ), ZEF( 50 , 7 ), A( 50 , 7 ), * BF( 50 , 7 ), DIF( 50 , 7 ), B( 50 , 7 ), * FF( 50 , 7 ), UF( 50 , 7 ), F( 50 , 7 ), * GF( 50 , 7 ), VF( 50 , 7 ), G( 50 , 7 ), * UQF( 50 , 6 ), UQFF( 50 , 6 ), * VQF( 50 , 6 ), VQFF( 50 , 6 ), * RQF( 50 , 6 ), RQFF( 50 , 6 ), RTG( 50 , 6 ) COMMON * U1( 50 ),V1( 50 ),T1( 50 ),Q1( 50 ), * U2( 50 ),V2( 50 ),T2( 50 ),Q2( 50 ) COMMON/PLNCOM/PLN( 306 ),DER( 289 ),PLNWCS( 289 ),EPS( 306 ), 1 COLRAD( 21 ),WGT( 21 ),WGTCS( 21 ),RCS2( 21 ) DOUBLE PRECISION COLRAD,EPS COMMON/VERCOM/AM( 7 , 7 ),HM( 7 , 7 ),TM( 7 , 7 ), O BM( 7 , 7 ),CM( 7 , 7 ),EKIN( 7 ), 1 SI( 8 ),SL( 7 ),DEL( 7 ),RDEL2( 7 ),RMSDOT( 6 ), 2 CI( 8 ),CL( 7 ),TOV( 7 ), SV( 7 ), RPI( 6 ), 3 P1( 7 ),P2( 7 ), H1( 7 ), H2( 7 ),RPIREC( 6 ), 4 ROTSIN,ROTCOS,SEADRY,SL1KAP,C1,C2,RLRV,SL100K C ----------------------MEMBER GCOM--------------------------------- CCCC CALL STIMER CALL XSTORE(EKIN(1),0., 7 ) CALL XSTORE(RMSDOT(1),0., 6 ) CALL DELLNP (Q, DPDPHI, DPDLAM, EPS) C REMOVE MEAN FROM TEMP. DO 2 LEV=1, 7 RELVOR(LEV) = ZE(2,LEV) ABSVOR(LEV) = RELVOR(LEV) + CMPLX(1.19045E-4,0.) TE(1,LEV)=TE(1,LEV)-CMPLX(TOV(LEV)*1.4142135,0.) 2 CONTINUE CJPB CALL XSTORE( Y(1,1),0.,2* 289 * 7 ) CALL YSTORE( Y(1,1),(0.,0.), 289 * 7 ) CJPB CALL XSTORE( W(1,1),0.,2* 289 * 7 ) CALL YSTORE( W(1,1),(0.,0.), 289 * 7 ) CJPB CALL XSTORE(Z(1),0.,2* 289 ) CALL YSTORE(Z(1),(0.,0.), 289 ) CJPB CALL XSTORE(RT(1,1),0.,2* 289 * 6 ) CALL YSTORE(RT(1,1),(0.,0.), 289 * 6 ) DO 5 LEV=1, 7 CALL XMOVEX(X(1,LEV),GZ(1),8* 289 ) 5 CONTINUE C X NOW CONTAINS CONTRIB. FROM TOPOG. C************************************************ C***** LAT LOOP C************************************************ DO 1000 LAT = 1, 21 CALL PLN2(PLN,COLRAD,LAT,EPS) CALL SUMPLS(Q,PS,QF,PLN) CALL SUMPLS(DPDLAM,DLAM,DLAMF,PLN) CALL SUMPLV(DPDPHI,DPHI,DPHIF,PLN) CALL LEGUV(PLN,PLNWCS,DER,EPS) DO 9 K=1, 7 ZE(2,K) = RELVOR(K) CALL UVGLOB(PLNWCS,DER,DI(1,K),ZE(1,K),FF(1,K),UF(1,K), 1 GF(1,K),VF(1,K)) ZE(2,K) = ABSVOR(K) 9 CONTINUE CALL UVGLOB(PLNWCS,DER,DIM,ZEM,U1,U2,V1,V2) DO 10 K=1, 7 CALL SUMPLS (DI(1,K),BF(1,K),DIF(1,K),PLN) CALL SUMPLS (TE(1,K),TF(1,K),TEF(1,K),PLN) CALL SUMPLS (ZE(1,K),AF(1,K),ZEF(1,K),PLN) 10 CONTINUE DO 8 K=1, 6 CALL SUMPLS(RQ(1,K),RQF(1,K),RQFF(1,K),PLN) 8 CONTINUE CALL SUMPLS(TEM,T1,T2,PLN) CALL SUMPLS( RM,Q1,Q2,PLN) SINLAT=SNGL(DCOS(COLRAD(LAT))) LATCO=LAT CALL GFIDI(BF,TF,FF,GF,AF,RQF,PS,DPHI,DLAM,CG, *A,B,F,G,EF,RTG,TAU,UQF,VQF,RCS2(LAT),SINLAT, * GRGRID(1, LATCO),TSEA(1,LATCO),U1,V1,T1,Q1) SINLAT=-SINLAT LATCO= 42 +1-LAT CALL GFIDI(DIF,TEF,UF,VF,ZEF,RQFF,QF,DPHIF,DLAMF,CG, *A,B,F,G,EEF,RTG,TAU,UQFF,VQFF,RCS2(LAT),SINLAT, * GRGRID(1, LATCO),TSEA(1,LATCO),U2,V2,T2,Q2) C DO 88 K=1, 6 CALL SYMASY(UQF(1,K),UQFF(1,K)) CALL SYMASY(VQF(1,K),VQFF(1,K)) CALL SYMASY(RQF(1,K),RQFF(1,K)) 88 CONTINUE CALL SYMASY(DLAM,DLAMF) DO 15 K=1, 7 CALL SYMASY (EF(1,K),EEF(1,K)) CALL SYMASY (TF(1,K),TEF(1,K)) CALL SYMASY (AF(1,K),ZEF(1,K)) CALL SYMASY (BF(1,K),DIF(1,K)) CALL SYMASY (FF(1,K), UF(1,K)) CALL SYMASY (GF(1,K), VF(1,K)) 15 CONTINUE DO 90 I=1, 306 PLN(I)=PLN(I)*WGT(LAT) 90 CONTINUE C COMPUTE NON,LIN,CONTRIB. TO V DEL LNP CALL FL22(DLAM,DLAMF,Z,PLN) C COMPUTE NON,LIN, CONTRIB. TO Y FROM TAU DO 16 K=1, 7 CALL FL22(TF(1,K),TEF(1,K),Y(1,K),PLN) 16 CONTINUE DO 99 K=1, 6 CALL FL22(RQF(1,K),RQFF(1,K),RT(1,K),PLN) 99 CONTINUE CALL GOZRIM (PLN, DER, EPS, LAT, PLNWCS, RCS2) DO 109 K=1, 6 CALL MSU22(UQFF(1,K),UQF(1,K),VQFF(1,K),VQF(1,K),RT(1,K),PLNWCS, 1 DER ) 109 CONTINUE DO 17 K=1, 7 CALL PSU22(ZEF(1,K),AF(1,K),DIF(1,K),BF(1,K),X(1,K),PLNWCS,DER) CALL MSU22(ZEF(1,K),AF(1,K),DIF(1,K),BF(1,K),W(1,K),PLNWCS,DER) CALL MSU22( UF(1,K),FF(1,K), VF(1,K),GF(1,K),Y(1,K),PLNWCS,DER) C*** FL22 ACTS AS LAPLACIAN ACCUMULATOR . SEE PLN FROM GOZRIM CALL FL22(EF(1,K),EEF(1,K),X(1,K),PLN) 17 CONTINUE 1000 CONTINUE C RESTORE TEMP. REL. VORTICITY DO 18 LEV=1, 7 TE(1,LEV)=TE(1,LEV)+CMPLX(TOV(LEV)*1.4142135,0.) ZE(2,LEV) = RELVOR(LEV) 18 CONTINUE CCCC CALL TTIMER(TPS) C(DEBUGLINE) VERSION CREATED JULY 8 1982 BY J.SELA,NMC. RETURN END