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