      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
