      SUBROUTINE GFIDI(DG,TG,UG,VG,ZG,RQG,PS,DPHI,DLAM,CG,
     * A,B,F,G,EG,RTG,TAU,UQ,VQ,RCL,SINLAT,CD,TSEA,U1,V1,T1,Q1)
      DIMENSION PS( 50 ),DPHI( 50 ),DLAM( 50 ),
     * DG( 50 , 7 ), ZG( 50 , 7 ), TG( 50 , 7 ),
     * UG( 50 , 7 ), VG( 50 , 7 ), CG( 50 , 7 ),
     * EG( 50 , 7 ),TAU( 50 , 7 ),
     *  A( 50 , 7 ),  B( 50 , 7 ),
     *  F( 50 , 7 ),  G( 50 , 7 ),
     *RQG( 50 , 6 ),RTG( 50 , 6 ),
     * UQ( 50 , 6 ), VQ( 50 , 6 )
      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
      DIMENSION CD( 50 ),TSEA( 50 ),
     * U1( 50 ),V1( 50 ),T1( 50 ),Q1( 50 )
      DIMENSION DB( 7 ),CB( 7 ),DOT( 8 )
      DIMENSION DUP( 7 ),DVP( 7 ),DUM( 7 ),DVM( 7 )
      DATA DOT/ 8 *0./,
     1DUM/ 7 *0./,DVM/ 7 *0./,DUP/ 7 *0./,DVP/ 7 *0./
      CALL FFS99(DG,CG, 7 )
      CALL FFS99(TG,CG, 7 )
      CALL FFS99(UG,CG, 7 )
      CALL FFS99(VG,CG, 7 )
      CALL FFS99(ZG,CG, 7 )
      CALL FFS99(RQG,CG, 6 )
      CALL FFS99(PS,CG,3)
C*** ABOVE ASSUMES PS DPHI DLAM ARE CONSECUTIVE IN CORE
      RCL2=0.5*RCL
      DO 2 LE=1, 7
      DO 1 LO=1, 50
      A(LO,LE)=ZG(LO,LE)*UG(LO,LE)+ 287.05 *TG(LO,LE)*DPHI(LO)
      B(LO,LE)=ZG(LO,LE)*VG(LO,LE)- 287.05 *TG(LO,LE)*DLAM(LO)
1     CONTINUE
      DO 11 LO=1, 50
      F(LO,LE)=TG(LO,LE)*UG(LO,LE)
      G(LO,LE)=TG(LO,LE)*VG(LO,LE)
      ZG(LO,LE)=(UG(LO,LE)*UG(LO,LE)+VG(LO,LE)*VG(LO,LE))*RCL2
11    CONTINUE
2     CONTINUE
      CALL FFA99(ZG,EG,TAU, 7 )
      DO 201 K=1, 6
      DO 200 LO=1, 50
      RTG(LO,K)=UG(LO,K)*RQG(LO,K)
200   CONTINUE
201   CONTINUE
      CALL FFA99(RTG,UQ,CG, 6 )
      DO 203 K=1, 6
      DO 202 LO=1, 50
      RTG(LO,K)=VG(LO,K)*RQG(LO,K)
202   CONTINUE
203   CONTINUE
      CALL FFA99(RTG,VQ,CG, 6 )
C     COMPUTE C=V(TRUE)*DEL(LN(PS)).DIVIDE BY COS FOR DEL COS FOR V
      DO 3 LO=1, 50
      DPHI(LO)=DPHI(LO)*RCL
      DLAM(LO)=DLAM(LO)*RCL
3     CONTINUE
      DO 5 LE=1, 7
      DO 4 LO=1, 50
      CG(LO,LE)=UG(LO,LE)*DLAM(LO)+VG(LO,LE)*DPHI(LO)
4     CONTINUE
5     CONTINUE
C----- LOWER LAYER DRAG ----------------------------
      CALL FFS99(U1,TAU,4)
      ROTCS=ROTSIN*SINLAT
      DO 50 I=1, 50
      DLAM(I)=CD(I)*SQRT(ZG(I,1))
50    CONTINUE
      DO 52 I=1, 50
      A(I,1)=A(I,1)+DLAM(I)*(V1(I)*ROTCOS+U1(I)*ROTCS)
      B(I,1)=B(I,1)-DLAM(I)*(U1(I)*ROTCOS-V1(I)*ROTCS)
52    CONTINUE
      DO 54 I=1, 50
      DLAM(I)=DLAM(I)+SEADRY*ZG(I,1)
      IF(TSEA(I).LT.0.) DLAM(I)=0.
54    CONTINUE
C***  DLAM NOW CONTAINS LAND SEA TERM. USE IN EVAP. AND SURF. HEATING
C---------------- END FRICTION ---------
      RK= 287.05 / 1005.
      DO 1000 LO=1, 50
      DB(1)=DEL(1)*DG(LO,1)
      CB(1)=DEL(1)*CG(LO,1)
      DO 6 LE=1, 6
      DB(LE+1)=DB(LE)+DEL(LE+1)*DG(LO,LE+1)
      CB(LE+1)=CB(LE)+DEL(LE+1)*CG(LO,LE+1)
6     CONTINUE
C---  STORE INTEGRAL OF CG IN DPHI ----------
      DPHI(LO)=-CB( 7 )
C
C     SIGMA DOT COMPUTED ONLY AT INTERIOR INTERFACES
      DO 7 K=1, 6
      DOT(K+1)=DOT(K)+DEL(K)*(DB( 7 )+CB( 7 )-DG(LO,K)-CG(LO,K))
7     CONTINUE
      DO 8 K=1, 7
      TAU(LO,K)=TG(LO,K)*(DG(LO,K)-RK*DB( 7 ))+
     1 RK*(TOV(K)+TG(LO,K))*(CG(LO,K)-CB( 7 ))
8      CONTINUE
      DO 12 K=1, 6
      DVP(K)=VG(LO,K+1)-VG(LO,K)
      DUP(K)=UG(LO,K+1)-UG(LO,K)
12    CONTINUE
      DO 13 K=1, 6
      DVM(K+1)=VG(LO,K+1)-VG(LO,K)
      DUM(K+1)=UG(LO,K+1)-UG(LO,K)
13    CONTINUE
      DO 14 K=1, 7
      A(LO,K)=A(LO,K)+ RDEL2(K)*(DOT(K+1)*DVP(K)+DOT(K)*DVM(K))
14    CONTINUE
      DO 15 K=1, 7
      B(LO,K)=B(LO,K)- RDEL2(K)*(DOT(K+1)*DUP(K)+DOT(K)*DUM(K))
15    CONTINUE
      DO 16 K=1, 6
      DUP(K)=P1(K)*TG(LO,K+1)-TG(LO,K)
      DVP(K)=CI(K+1)*CB( 7 )-CB(K)
16    CONTINUE
      DO 17 K=1, 6
      DUM(K+1)=TG(LO,K+1)-P2(K+1)*TG(LO,K)
      DVM(K+1)=CI(K+1)*CB( 7 )-CB(K)
17    CONTINUE
      DO 18 K=1, 7
C     H1 H2 COME FROM BMCM
      TAU(LO,K)=TAU(LO,K)-RDEL2(K)*(DOT(K+1)*DUP(K)+DOT(K)*DUM(K) +
     1H1(K)*DVP(K) + H2(K)*DVM(K)  )
18    CONTINUE
      DO 30 K=1, 5
      DUP(K)=RQG(LO,K+1)-RQG(LO,K)
30    CONTINUE
      DUP( 6 )=0.
      DO 32 K=1, 5
      DUM(K+1)=RQG(LO,K+1)-RQG(LO,K)
32    CONTINUE
      DO 34 K=1, 6
      RTG(LO,K)=DG(LO,K)*RQG(LO,K)   -
     1     RDEL2(K)*(DOT(K+1)*DUP(K)+DOT(K)*DUM(K))
34    CONTINUE
1000  CONTINUE
C*** EVAPORATION INTO LOWEST LAYER -----
      DO 56 I=1, 50
      U1(I)=PS(I)-RLRV/TSEA(I)
56    CONTINUE
      DO 58 I=1, 50
      U1(I)=EXP(U1(I))
58    CONTINUE
      DO 60 I=1, 50
      V1(I)=C1*0.9/(U1(I)+C2)
60    CONTINUE
C*** V1 IS QSAT AT SEA TEMP SCALED BY 0.9
C**** QS AT LAYER 1 IS USED TO SHUT OFF EVAP. INTO SATURATED LAYER
      DO 61 I=1, 50
      U1(I)=PS(I)-RLRV/T1(I)
61    CONTINUE
      DO 63 I=1, 50
      U1(I)=EXP(U1(I))
63    CONTINUE
      DO 64 I=1, 50
      U1(I)=C1*0.9/(SL(1)*U1(I)+C2)
64    CONTINUE
C*** U1 IS SAT Q AT LAYER 1 SCALED TO .9
      DO 62 I=1, 50
      IF( (Q1(I).GT.U1(I))  .OR. (Q1(I).GT.V1(I)) ) GO TO 62
      RTG(I,1)=RTG(I,1)+DLAM(I)*(V1(I)-Q1(I))*.5
62    CONTINUE
C*** HEATING OF LOWEST LAYER FROM UNDERLYING WATER.T1*SL1KAP=T SURF
      DO 70 I=1, 50
      TDIFS1=TSEA(I)-T1(I)*SL1KAP
      IF(TDIFS1.LT.0.) GO TO 70
      TAU(I,1)=TAU(I,1)+DLAM(I)*TDIFS1*.5
70    CONTINUE
C*** RETURN TO COEFS.
      CALL FFA99(DPHI,DLAM,CG,1)
      CALL FFA99(A,ZG,CG, 7 )
      CALL FFA99(B,DG,CG, 7 )
      CALL FFA99(F,UG,CG, 7 )
      CALL FFA99(G,VG,CG, 7 )
      CALL FFA99(TAU,TG,CG, 7 )
      CALL FFA99(RTG,RQG,CG, 6 )
C(DEBUGLINE) VERSION CREATED JULY 8 1982 BY J.SELA,NMC.
      RETURN
      END
