SUBROUTINE SNONLIN (F, FL, IJS, IJL, IG, SL, AKMEAN, SSNL4, DSSNL4) ! ---------------------------------------------------------------------- !**** *SNONLIN* - COMPUTATION OF NONLINEAR TRANSFER RATE AND ITS !**** FUNCTIONAL DERIVATIVE (DIAGONAL TERMS ONLY) AND !**** ADDITION TO CORRESPONDING NET EXPRESSIONS. ! S.D. HASSELMANN. MPI ! G. KOMEN, P. JANSSEN KNMI MODIFIED TO SHALLOW WATER ! H. GUENTHER, L. ZAMBRESKY OPTIMIZED ! H. GUENTHER GKSS/ECMWF JUNE 1991 INTERACTIONS BETWEEN DIAG- ! AND PROGNOSTIC PART. ! J. BIDLOT ECMWF FEBRUARY 1997 ADD SL IN SUBROUTINE CALL ! P. JANSSEN ECMWF JUNE 2005 IMPROVED SCALING IN SHALLOW ! WATER ! J. BIDLOT ECMWF AUGUST 2006 KEEP THE OLD FORMULATION ! UNDER A SWITCH (ISNONLIN = 0 for OLD ! = 1 for NEW ! BE AWARE THAT THE OLD FORMULATION ! REQUIRES THE MEAN WAVE NUMBER AKMEAN. ! J. BIDLOT ECMWF JANUARY 2012 ADD EXTENSION TO LOW FREQUENCIES ! OPTIMISATION FOR IBM. !* PURPOSE. ! -------- ! SEE ABOVE. !** INTERFACE. ! ---------- ! *CALL* *SNONLIN (F, FL, IJS, IJL, IG, SL)* ! *F* - SPECTRUM. ! *FL* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE ! *IJS* - INDEX OF FIRST GRIDPOINT ! *IJL* - INDEX OF LAST GRIDPOINT ! *IG* - BLOCK NUMBER. ! *SL* - TOTAL SOURCE FUNCTION ARRAY. ! METHOD. ! ------- ! NONE. ! EXTERNALS. ! ---------- ! NONE. ! REFERENCE. ! ---------- ! NONE. ! ---------------------------------------------------------------------- ! USE YOWPARAM , ONLY : NANG ,NFRE ! USE YOWINDN , ONLY : IKP ,IKP1 ,IKM ,IKM1 , ! & K1W ,K2W ,K11W ,K21W ,AF11 , ! & FKLAP ,FKLAP1 ,FKLAM ,FKLAM1 ,ACL1 , ! & ACL2 ,CL11 ,CL21 ,DAL1 ,DAL2 , ! & FRH ,ENH ! USE YOWSHAL , ONLY : DEPTH ,TFAK, INDEP ! USE YOWSTAT , ONLY : ISHALLO ,ISNONLIN ! USE YOMHOOK ,ONLY : LHOOK, DR_HOOK USE DATAPOOL, ONLY : FR, WETAIL, FRTAIL, WP1TAIL, ISHALLO, FRINTF, COFRM4, CG, WK, ISNONLIN, & & DFIM, DFIMOFR, DFFR, DFFR2, WK, RKIND, EMEAN, FMEAN, TH, ENH, DEP, AF11, & & IKP, IKP1, IKM, IKM1, K1W, K2W, K11W, K21W, FKLAP, FKLAP1, FKLAM, FKLAM1, FRH, & & CL11, CL21, DAL1, DAL2, ACL1, ACL2, MLSTHG, MFRSTLW, KFRH, RNLCOEF, INLCOEF, & & DELTH => DDIR, LOUTWAM, ICOMP, ZERO, & & G => G9, & & ZPI => PI2, & & EPSMIN => SMALL, & & NANG => MDC, & & NFRE => MSC, & & INDEP => DEP IMPLICIT NONE ! ---------------------------------------------------------------------- INTEGER :: MFR1STFR, MFRLSTFR INTEGER :: MP, MC1, MP1, MM, MM1, MC INTEGER :: IJ, IG, IP, IP1, IC, IM, IM1, M INTEGER :: K, K1, K2, KH, K11, K21, IJS, IJL REAL(rkind),DIMENSION(IJS:IJL) :: FTEMP,AD,DELAD,DELAP,DELAM REAL(rkind),DIMENSION(IJS:IJL) :: AKMEAN,ENHFR REAL(rkind),DIMENSION(IJS:IJL,NANG,NFRE) :: F,FL,SL REAL(rkind),DIMENSION(NANG,NFRE) :: DSSNL4, SSNL4 REAL(rkind) :: FKLAMMA, FKLAMMB, FKLAMM2, FKLAMA2, FKLAMB2, FKLAM12, FKLAM22 REAL(rkind) :: FKLAMP2, FKLAPA2, FKLAPB2, FKLAP12, FKLAP22, FKLAMM, FKLAMM1 REAL(rkind) :: FKLAMP, FKLAMP1, FKLAMPA, FKLAMPB, FLSUM, SLSUM REAL(rkind) :: GW1, GW2, GW3, GW4, GW5, GW6, GW7, GW8 REAL(rkind) :: FIJ, SAP, SAM , FAD1, FAD2, FCEN, FTAIL FLSUM = 0.d0 SLSUM = 0.d0 DSSNL4 = ZERO SSNL4 = ZERO ! REAL ZHOOK_HANDLE ! IF (LHOOK) CALL DR_HOOK('SNONLIN',0,ZHOOK_HANDLE) ! ---------------------------------------------------------------------- !* 1. SHALLOW WATER INITIALISATION (ONLY FOR THE OLD FORMULATION). ! ----------------------------- SEE INITMDL FOR THE NEW ONE IF (ISHALLO.NE.1) THEN IF (ISNONLIN.EQ.0) THEN DO IJ=IJS,IJL !AR: change dep to depth to dep in WWM ENHFR(IJ) = 0.75*DEP(IJ)*AKMEAN(IJ) ENHFR(IJ) = MAX(ENHFR(IJ),.5) ENHFR(IJ) = 1.+(5.5/ENHFR(IJ))*(1.-.833*ENHFR(IJ)) * & & EXP(-1.25*ENHFR(IJ)) ENDDO DO MC=1,MLSTHG DO IJ=IJS,IJL ENH(IJ,MC,IG) = ENHFR(IJ) ENDDO ENDDO ENDIF ENDIF !* 2. FREQUENCY LOOP. ! --------------- MFR1STFR=-MFRSTLW+1 MFRLSTFR=NFRE-KFRH+MFR1STFR ! WRITE(111117,'(I10,10F15.8)') IG, SUM(F), SUM(FL),SUM(SL), AKMEAN ! DO IJ=IJS,IJL ! WRITE(111117,'(5I10,10F15.8)') ISHALLO, ISNONLIN, MLSTHG, & ! & MFRSTLW, MFR1STFR, SUM(ENH(IJ,:,:)) ! ENDDO ! WRITE(111117,'(5I10,10F15.8)') SUM(INLCOEF), SUM(IKP), SUM(IKP1), & ! &SUM(IKM), SUM(IKM1), SUM(FKLAP), SUM(FKLAP1), SUM(RNLCOEF) ! WRITE(111117,'(4I10,10F20.8)') SUM(K1W), SUM(K2W), SUM(K11W), & ! &SUM(K21W), SUM(AF11) DO MC=1,MLSTHG MP = IKP (MC) MP1 = IKP1(MC) MM = IKM (MC) MM1 = IKM1(MC) IC = INLCOEF(1,MC) IP = INLCOEF(2,MC) IP1 = INLCOEF(3,MC) IM = INLCOEF(4,MC) IM1 = INLCOEF(5,MC) FTAIL = RNLCOEF(1,MC) FKLAMP = FKLAP(MC) FKLAMP1 = FKLAP1(MC) GW1 = RNLCOEF(2,MC) GW2 = RNLCOEF(3,MC) GW3 = RNLCOEF(4,MC) GW4 = RNLCOEF(5,MC) FKLAMPA = RNLCOEF(6,MC) FKLAMPB = RNLCOEF(7,MC) FKLAMP2 = RNLCOEF(8,MC) FKLAMP1 = RNLCOEF(9,MC) FKLAPA2 = RNLCOEF(10,MC) FKLAPB2 = RNLCOEF(11,MC) FKLAP12 = RNLCOEF(12,MC) FKLAP22 = RNLCOEF(13,MC) FKLAMM = FKLAM(MC) FKLAMM1 = FKLAM1(MC) GW5 = RNLCOEF(14,MC) GW6 = RNLCOEF(15,MC) GW7 = RNLCOEF(16,MC) GW8 = RNLCOEF(17,MC) FKLAMMA = RNLCOEF(18,MC) FKLAMMB = RNLCOEF(19,MC) FKLAMM2 = RNLCOEF(20,MC) FKLAMM1 = RNLCOEF(21,MC) FKLAMA2 = RNLCOEF(22,MC) FKLAMB2 = RNLCOEF(23,MC) FKLAM12 = RNLCOEF(24,MC) FKLAM22 = RNLCOEF(25,MC) IF (ISHALLO.EQ.1) THEN DO IJ=IJS,IJL FTEMP(IJ) = AF11(MC) ENDDO ELSE DO IJ=IJS,IJL FTEMP(IJ) = AF11(MC)*ENH(IJ,MC,IG) ENDDO ENDIF IF (MC.GT.MFR1STFR .AND. MC.LT.MFRLSTFR ) THEN ! MC is within the fully resolved spectral domain DO KH=1,2 DO K=1,NANG K1 = K1W (K,KH) K2 = K2W (K,KH) K11 = K11W(K,KH) K21 = K21W(K,KH) !* 2.1.1.1 LOOP OVER GRIDPOINTS.. NONLINEAR TRANSFER AND !* DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. ! ---------------------------------------------- DO IJ=IJS,IJL SAP = GW1*F(IJ,K1 ,IP ) + GW2*F(IJ,K11,IP ) & & + GW3*F(IJ,K1 ,IP1) + GW4*F(IJ,K11,IP1) SAM = GW5*F(IJ,K2 ,IM ) + GW6*F(IJ,K21,IM ) & & + GW7*F(IJ,K2 ,IM1) + GW8*F(IJ,K21,IM1) !!!! not needed ftail always=1. FIJ = F(IJ,K ,IC )*FTAIL FIJ = F(IJ,K ,IC ) FAD1 = FIJ*(SAP+SAM) FAD2 = FAD1-2.*SAP*SAM FAD1 = FAD1+FAD2 FCEN = FTEMP(IJ)*FIJ AD(IJ) = FAD2*FCEN DELAD(IJ) = FAD1*FTEMP(IJ) DELAP(IJ) = (FIJ-2.*SAM)*DAL1*FCEN DELAM(IJ) = (FIJ-2.*SAP)*DAL2*FCEN ENDDO DO IJ=IJS,IJL SL(IJ,K ,MC ) = SL(IJ,K ,MC ) - 2.*AD(IJ) SSNL4(K,MC ) = SSNL4(K,MC ) - 2.*AD(IJ) ENDDO DO IJ=IJS,IJL FL(IJ,K ,MC ) = FL(IJ,K ,MC ) - 2.*DELAD(IJ) DSSNL4(K,MC ) = DSSNL4(K,MC ) - 2.*DELAD(IJ) ENDDO DO IJ=IJS,IJL SL(IJ,K2 ,MM ) = SL(IJ,K2 ,MM ) + AD(IJ)*FKLAMM1 SSNL4(K2,MM) = SSNL4(K2,MM) + AD(IJ)*FKLAMM1 ENDDO DO IJ=IJS,IJL FL(IJ,K2 ,MM ) = FL(IJ,K2 ,MM ) + DELAM(IJ)*FKLAM12 DSSNL4(K2,MM) = DSSNL4(K2,MM) + DELAM(IJ)*FKLAM12 ENDDO DO IJ=IJS,IJL SL(IJ,K21,MM ) = SL(IJ,K21,MM ) + AD(IJ)*FKLAMM2 SSNL4(K21,MM) = SSNL4(K21,MM) + AD(IJ)*FKLAMM2 ENDDO DO IJ=IJS,IJL FL(IJ,K21,MM ) = FL(IJ,K21,MM ) + DELAM(IJ)*FKLAM22 DSSNL4(K21,MM) = DSSNL4(K21,MM) + DELAM(IJ)*FKLAM22 ENDDO DO IJ=IJS,IJL SL(IJ,K2 ,MM1) = SL(IJ,K2 ,MM1) + AD(IJ)*FKLAMMA SSNL4(K2,MM1) = SSNL4(K2,MM1) + AD(IJ)*FKLAMMA ENDDO DO IJ=IJS,IJL FL(IJ,K2 ,MM1) = FL(IJ,K2 ,MM1) + DELAM(IJ)*FKLAMA2 DSSNL4(K2,MM1) = DSSNL4(K2,MM1) + DELAM(IJ)*FKLAMA2 ENDDO DO IJ=IJS,IJL SL(IJ,K21,MM1) = SL(IJ,K21,MM1) + AD(IJ)*FKLAMMB SSNL4(K21,MM1) = SSNL4(K21,MM1) + AD(IJ)*FKLAMMB ENDDO DO IJ=IJS,IJL FL(IJ,K21,MM1) = FL(IJ,K21,MM1) + DELAM(IJ)*FKLAMB2 DSSNL4(K21,MM1) = DSSNL4(K21,MM1) + DELAM(IJ)*FKLAMB2 ENDDO DO IJ=IJS,IJL SL(IJ,K1 ,MP ) = SL(IJ,K1 ,MP ) + AD(IJ)*FKLAMP1 SSNL4(K1,MP) = SSNL4(K1,MP) + AD(IJ)*FKLAMP1 ENDDO DO IJ=IJS,IJL FL(IJ,K1 ,MP ) = FL(IJ,K1 ,MP ) + DELAP(IJ)*FKLAP12 DSSNL4(K1,MP) = DSSNL4(K1,MP) + DELAP(IJ)*FKLAP12 ENDDO DO IJ=IJS,IJL SL(IJ,K11,MP ) = SL(IJ,K11,MP ) + AD(IJ)*FKLAMP2 SSNL4(K11,MP) = SSNL4(K11,MP) + AD(IJ)*FKLAMP2 ENDDO DO IJ=IJS,IJL FL(IJ,K11,MP ) = FL(IJ,K11,MP ) + DELAP(IJ)*FKLAP22 DSSNL4(K11,MP) = DSSNL4(K11,MP) + AD(IJ)*FKLAMP2 ENDDO DO IJ=IJS,IJL SL(IJ,K1 ,MP1) = SL(IJ,K1 ,MP1) + AD(IJ)*FKLAMPA SSNL4(K1,MP1) = SSNL4(K1,MP1) + AD(IJ)*FKLAMPA ENDDO DO IJ=IJS,IJL FL(IJ,K1 ,MP1) = FL(IJ,K1 ,MP1) + DELAP(IJ)*FKLAPA2 DSSNL4(K1,MP1) = DSSNL4(K1,MP1) + DELAP(IJ)*FKLAPA2 ENDDO DO IJ=IJS,IJL SL(IJ,K11,MP1) = SL(IJ,K11,MP1) + AD(IJ)*FKLAMPB SSNL4(K11,MP1) = SSNL4(K11,MP1) + AD(IJ)*FKLAMPB ENDDO DO IJ=IJS,IJL FL(IJ,K11,MP1) = FL(IJ,K11,MP1) + DELAP(IJ)*FKLAPB2 DSSNL4(K11,MP1) = DSSNL4(K11,MP1) + DELAP(IJ)*FKLAPB2 ENDDO ENDDO ENDDO ELSEIF (MC.GE.MFRLSTFR ) THEN DO KH=1,2 DO K=1,NANG K1 = K1W (K,KH) K2 = K2W (K,KH) K11 = K11W(K,KH) K21 = K21W(K,KH) DO IJ=IJS,IJL SAP = GW1*F(IJ,K1 ,IP ) + GW2*F(IJ,K11,IP ) & & + GW3*F(IJ,K1 ,IP1) + GW4*F(IJ,K11,IP1) SAM = GW5*F(IJ,K2 ,IM ) + GW6*F(IJ,K21,IM ) & & + GW7*F(IJ,K2 ,IM1) + GW8*F(IJ,K21,IM1) FIJ = F(IJ,K ,IC )*FTAIL FAD1 = FIJ*(SAP+SAM) FAD2 = FAD1-2.*SAP*SAM FAD1 = FAD1+FAD2 FCEN = FTEMP(IJ)*FIJ AD(IJ) = FAD2*FCEN DELAD(IJ) = FAD1*FTEMP(IJ) DELAP(IJ) = (FIJ-2.*SAM)*DAL1*FCEN DELAM(IJ) = (FIJ-2.*SAP)*DAL2*FCEN ! WRITE(111117,'(3I10,5F20.10)')KH,K,MC,FTAIL,RNLCOEF(1,MC) ! WRITE(111117,'(6F20.10)') FAD1,FAD2,FCEN,DELAD(IJ) ! WRITE(111117,'(5F20.15)') DELAM(IJ),FIJ ! WRITE(111117,'(5F30.20)') FCEN, FTEMP(IJ), FIJ, FTAIL ENDDO DO IJ=IJS,IJL SL(IJ,K2 ,MM ) = SL(IJ,K2 ,MM ) + AD(IJ)*FKLAMM1 SSNL4(K2,MM) = SSNL4(K2,MM) + AD(IJ)*FKLAMM1 ENDDO DO IJ=IJS,IJL FL(IJ,K2 ,MM ) = FL(IJ,K2 ,MM ) + DELAM(IJ)*FKLAM12 DSSNL4(K2,MM) = DSSNL4(K2,MM) + DELAM(IJ)*FKLAM12 ENDDO DO IJ=IJS,IJL SL(IJ,K21,MM ) = SL(IJ,K21,MM ) + AD(IJ)*FKLAMM2 SSNL4(K21,MM) = SSNL4(K21,MM) + AD(IJ)*FKLAMM1 ENDDO DO IJ=IJS,IJL FL(IJ,K21,MM ) = FL(IJ,K21,MM ) + DELAM(IJ)*FKLAM22 DSSNL4(K21,MM) = DSSNL4(K21,MM) + DELAM(IJ)*FKLAM22 ENDDO IF (MM1.LE.NFRE) THEN DO IJ=IJS,IJL SL(IJ,K2 ,MM1) = SL(IJ,K2 ,MM1) + AD(IJ)*FKLAMMA SSNL4(K2,MM1) = SSNL4(K2,MM1) + AD(IJ)*FKLAMMA ENDDO DO IJ=IJS,IJL FL(IJ,K2 ,MM1) = FL(IJ,K2 ,MM1) + DELAM(IJ)*FKLAMA2 DSSNL4(K2,MM1) = DSSNL4(K2,MM1) + DELAM(IJ)*FKLAMA2 ENDDO DO IJ=IJS,IJL SL(IJ,K21,MM1) = SL(IJ,K21,MM1) + AD(IJ)*FKLAMMB SSNL4(K21,MM1) = SSNL4(K21,MM1) + AD(IJ)*FKLAMMB ENDDO DO IJ=IJS,IJL FL(IJ,K21,MM1) = FL(IJ,K21,MM1) + DELAM(IJ)*FKLAMB2 DSSNL4(K21,MM1) = DSSNL4(K21,MM1) + DELAM(IJ)*FKLAMB2 ENDDO IF (MC .LE.NFRE) THEN DO IJ=IJS,IJL SL(IJ,K ,MC ) = SL(IJ,K ,MC ) - 2.*AD(IJ) SSNL4(K,MC) = SSNL4(K,MC) - 2.*AD(IJ) ENDDO DO IJ=IJS,IJL FL(IJ,K ,MC ) = FL(IJ,K ,MC ) - 2.*DELAD(IJ) DSSNL4(K,MC) = DSSNL4(K,MC) - 2.*DELAD(IJ) ENDDO IF (MP .LE.NFRE) THEN DO IJ=IJS,IJL SL(IJ,K1 ,MP ) = SL(IJ,K1 ,MP ) + AD(IJ)*FKLAMP1 SSNL4(K1,MP) = SSNL4(K1,MP) + AD(IJ)*FKLAMP1 ENDDO DO IJ=IJS,IJL FL(IJ,K1 ,MP ) = FL(IJ,K1 ,MP ) & & + DELAP(IJ)*FKLAP12 DSSNL4(K1,MP) = DSSNL4(K1,MP) & & + DELAP(IJ)*FKLAP12 ENDDO DO IJ=IJS,IJL SL(IJ,K11,MP ) = SL(IJ,K11,MP ) + AD(IJ)*FKLAMP2 SSNL4(K11,MP) = SSNL4(K11,MP) + AD(IJ)*FKLAMP2 ENDDO DO IJ=IJS,IJL FL(IJ,K11,MP ) = FL(IJ,K11,MP ) & & + DELAP(IJ)*FKLAP22 DSSNL4(K11,MP) = DSSNL4(K11,MP) & & + DELAP(IJ)*FKLAP22 ENDDO IF (MP1.LE.NFRE) THEN DO IJ=IJS,IJL SL(IJ,K1 ,MP1) = SL(IJ,K1 ,MP1) & & + AD(IJ)*FKLAMPA SSNL4(K1 ,MP1) = SSNL4(K1 ,MP1) & + AD(IJ)*FKLAMPA ENDDO DO IJ=IJS,IJL FL(IJ,K1 ,MP1) = FL(IJ,K1 ,MP1) & & + DELAP(IJ)*FKLAPA2 DSSNL4(K1 ,MP1) = DSSNL4(K1 ,MP1) & + AD(IJ)*FKLAMPA ENDDO DO IJ=IJS,IJL SL(IJ,K11,MP1) = SL(IJ,K11,MP1) & & + AD(IJ)*FKLAMPB SSNL4(K1 ,MP1) = SSNL4(K1 ,MP1) & & + AD(IJ)*FKLAMPB ENDDO DO IJ=IJS,IJL FL(IJ,K11,MP1) = FL(IJ,K11,MP1) & & + DELAP(IJ)*FKLAPB2 DSSNL4(K11 ,MP1) = DSSNL4(K11 ,MP1) & & + DELAP(IJ)*FKLAPB2 ENDDO ENDIF ENDIF ENDIF ENDIF ENDDO ENDDO ELSE DO KH=1,2 DO K=1,NANG K1 = K1W (K,KH) K2 = K2W (K,KH) K11 = K11W(K,KH) K21 = K21W(K,KH) DO IJ=IJS,IJL SAP = GW1*F(IJ,K1 ,IP ) + GW2*F(IJ,K11,IP ) & & + GW3*F(IJ,K1 ,IP1) + GW4*F(IJ,K11,IP1) SAM = GW5*F(IJ,K2 ,IM ) + GW6*F(IJ,K21,IM ) & & + GW7*F(IJ,K2 ,IM1) + GW8*F(IJ,K21,IM1) FIJ = F(IJ,K ,IC )*FTAIL FAD1 = FIJ*(SAP+SAM) FAD2 = FAD1-2.*SAP*SAM FAD1 = FAD1+FAD2 FCEN = FTEMP(IJ)*FIJ AD(IJ) = FAD2*FCEN DELAD(IJ) = FAD1*FTEMP(IJ) DELAP(IJ) = (FIJ-2.*SAM)*DAL1*FCEN DELAM(IJ) = (FIJ-2.*SAP)*DAL2*FCEN ENDDO IF (MM1.GE.1) THEN DO IJ=IJS,IJL SL(IJ,K2 ,MM1) = SL(IJ,K2 ,MM1) + AD(IJ)*FKLAMMA SSNL4(K2,MM1) = SSNL4(K2,MM1) + AD(IJ)*FKLAMMA ENDDO DO IJ=IJS,IJL FL(IJ,K2 ,MM1) = FL(IJ,K2 ,MM1) + DELAM(IJ)*FKLAMA2 DSSNL4(K2,MM1) = DSSNL4(K2,MM1) + DELAM(IJ)*FKLAMA2 ENDDO DO IJ=IJS,IJL SL(IJ,K21,MM1) = SL(IJ,K21,MM1) + AD(IJ)*FKLAMMB SSNL4(K21,MM1) = SSNL4(K21,MM1) + AD(IJ)*FKLAMMB ENDDO DO IJ=IJS,IJL FL(IJ,K21,MM1) = FL(IJ,K21,MM1) + DELAM(IJ)*FKLAMB2 DSSNL4(K21,MM1) = DSSNL4(K21,MM1) + DELAM(IJ)*FKLAMB2 ENDDO ENDIF DO IJ=IJS,IJL SL(IJ,K ,MC ) = SL(IJ,K ,MC ) - 2.*AD(IJ) SSNL4(K,MC) = SSNL4(K,MC) - 2.*AD(IJ) ENDDO DO IJ=IJS,IJL FL(IJ,K ,MC ) = FL(IJ,K ,MC ) - 2.*DELAD(IJ) DSSNL4(K,MC) = DSSNL4(K,MC) - 2.*DELAD(IJ) ENDDO DO IJ=IJS,IJL SL(IJ,K1 ,MP ) = SL(IJ,K1 ,MP ) + AD(IJ)*FKLAMP1 SSNL4(K1,MP) = SSNL4(K1,MP) + AD(IJ)*FKLAMP1 ENDDO DO IJ=IJS,IJL FL(IJ,K1 ,MP ) = FL(IJ,K1 ,MP ) + DELAP(IJ)*FKLAP12 DSSNL4(K1,MP) = DSSNL4(K1,MP) + DELAP(IJ)*FKLAP12 ENDDO DO IJ=IJS,IJL SL(IJ,K11,MP ) = SL(IJ,K11,MP ) + AD(IJ)*FKLAMP2 SSNL4(K11,MP) = SSNL4(K11,MP) + AD(IJ)*FKLAMP2 ENDDO DO IJ=IJS,IJL FL(IJ,K11,MP ) = FL(IJ,K11,MP ) + DELAP(IJ)*FKLAP22 DSSNL4(K11,MP) = DSSNL4(K11,MP) + DELAP(IJ)*FKLAP22 ENDDO DO IJ=IJS,IJL SL(IJ,K1 ,MP1) = SL(IJ,K1 ,MP1) + AD(IJ)*FKLAMPA SSNL4(K1,MP1) = SSNL4(K1,MP1) + AD(IJ)*FKLAMPA ENDDO DO IJ=IJS,IJL FL(IJ,K1 ,MP1) = FL(IJ,K1 ,MP1) + DELAP(IJ)*FKLAPA2 DSSNL4(K1,MP1) = DSSNL4(K1,MP1) + DELAP(IJ)*FKLAPA2 ENDDO DO IJ=IJS,IJL SL(IJ,K11,MP1) = SL(IJ,K11,MP1) + AD(IJ)*FKLAMPB SSNL4(K11,MP1) = SSNL4(K11,MP1) + AD(IJ)*FKLAMPB ENDDO DO IJ=IJS,IJL FL(IJ,K11,MP1) = FL(IJ,K11,MP1) + DELAP(IJ)*FKLAPB2 DSSNL4(K11,MP1) = DSSNL4(K11,MP1) + DELAP(IJ)*FKLAPB2 ENDDO ENDDO ENDDO ENDIF !* BRANCH BACK TO 2. FOR NEXT FREQUENCY. DO IJ=IJS,IJL IF (MC.LE.NFRE) THEN FLSUM = FLSUM + SUM(FL(IJ,:,MC)) SLSUM = SLSUM + SUM(SL(IJ,:,MC)) ! WRITE(111117,'(I10,4F30.25)') MC, & ! & SUM(FL(IJ,:,MC)),SUM(SL(IJ,:,MC)) ! & FLSUM, SLSUM ENDIF ENDDO ENDDO ! IF (ICOMP .GE. 2) THEN ! DO M = 1, NFRE ! DO K = 1, NANG ! IF (SSNL4(K,M) .LT. ZERO) THEN ! SSNL4(K,M) = ZERO ! DSSNL4(K,M) = - DSSNL4(K,M) ! ELSE ! DSSNL4(K,M) = ZERO ! ENDIF ! END DO ! ENDDO ! ENDIF DO IJ=IJS,IJL ! WRITE(111117,'(2F30.25)') & ! & SUM(FL(IJ,:,:)),SUM(SL(IJ,:,:)) ! WRITE(111117,*) 'NOW THE FULL THING' ! DO K = 1, NANG ! DO M = 1, NFRE ! WRITE(111117,'(2I10,2F30.25)') & ! & K, M, FL(IJ,K,M), SL(IJ,K,M) ! ENDDO ! ENDDO ENDDO ! IF (LHOOK) CALL DR_HOOK('SNONLIN',1,ZHOOK_HANDLE) RETURN END SUBROUTINE SNONLIN