--- trunk/phylmd/Radlwsw/swu.f	2013/11/15 18:45:49	76
+++ trunk/phylmd/Radlwsw/swu.f	2014/12/18 17:30:24	118
@@ -1,190 +1,179 @@
-c
-cIM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
-      SUBROUTINE SWU (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
-     S                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
-     S                PRMU,PSEC,PUD)
-      use dimens_m
-      use dimphy
-      use clesphys
-      use SUPHEC_M
-      use raddim
-      use radepsi
-      use radopt
-      IMPLICIT none
-C
-C* ARGUMENTS:
-C
-      DOUBLE PRECISION PSCT
-cIM ctes ds clesphys.h   DOUBLE PRECISION RCO2
-      DOUBLE PRECISION PCLDSW(KDLON,KFLEV)
-      DOUBLE PRECISION PPMB(KDLON,KFLEV+1)
-      DOUBLE PRECISION PPSOL(KDLON)
-      DOUBLE PRECISION PRMU0(KDLON)
-      DOUBLE PRECISION PFRAC(KDLON)
-      DOUBLE PRECISION PTAVE(KDLON,KFLEV)
-      DOUBLE PRECISION PWV(KDLON,KFLEV)
-C
-      DOUBLE PRECISION PAKI(KDLON,2)
-      DOUBLE PRECISION PCLD(KDLON,KFLEV)
-      DOUBLE PRECISION PCLEAR(KDLON)
-      DOUBLE PRECISION PDSIG(KDLON,KFLEV)
-      DOUBLE PRECISION PFACT(KDLON)
-      DOUBLE PRECISION PRMU(KDLON)
-      DOUBLE PRECISION PSEC(KDLON)
-      DOUBLE PRECISION PUD(KDLON,5,KFLEV+1)
-C
-C* LOCAL VARIABLES:
-C
-      INTEGER IIND(2)
-      DOUBLE PRECISION ZC1J(KDLON,KFLEV+1)
-      DOUBLE PRECISION ZCLEAR(KDLON)
-      DOUBLE PRECISION ZCLOUD(KDLON)
-      DOUBLE PRECISION ZN175(KDLON)
-      DOUBLE PRECISION ZN190(KDLON)
-      DOUBLE PRECISION ZO175(KDLON)
-      DOUBLE PRECISION ZO190(KDLON)
-      DOUBLE PRECISION ZSIGN(KDLON)
-      DOUBLE PRECISION ZR(KDLON,2) 
-      DOUBLE PRECISION ZSIGO(KDLON)
-      DOUBLE PRECISION ZUD(KDLON,2)
-      DOUBLE PRECISION ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
-      INTEGER jl, jk, jkp1, jkl, jklp1, ja
-C
-C* Prescribed Data:
-c
-      DOUBLE PRECISION ZPDH2O,ZPDUMG
-      SAVE ZPDH2O,ZPDUMG
-      DOUBLE PRECISION ZPRH2O,ZPRUMG
-      SAVE ZPRH2O,ZPRUMG
-      DOUBLE PRECISION RTDH2O,RTDUMG
-      SAVE RTDH2O,RTDUMG
-      DOUBLE PRECISION RTH2O ,RTUMG
-      SAVE RTH2O ,RTUMG
-      DATA ZPDH2O,ZPDUMG / 0.8   , 0.75 /
-      DATA ZPRH2O,ZPRUMG / 30000., 30000. /
-      DATA RTDH2O,RTDUMG /  0.40  , 0.375 /
-      DATA RTH2O ,RTUMG  /  240.  , 240.  /
-C     ------------------------------------------------------------------
-C
-C*         1.     COMPUTES AMOUNTS OF ABSORBERS
-C                 -----------------------------
-C
- 100  CONTINUE
-C
-      IIND(1)=1
-      IIND(2)=2
-C      
-C
-C*         1.1    INITIALIZES QUANTITIES
-C                 ----------------------
-C
- 110  CONTINUE
-C
-      DO 111 JL = 1, KDLON
-      PUD(JL,1,KFLEV+1)=0.
-      PUD(JL,2,KFLEV+1)=0.
-      PUD(JL,3,KFLEV+1)=0.
-      PUD(JL,4,KFLEV+1)=0.
-      PUD(JL,5,KFLEV+1)=0.
-      PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
-      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
-      PSEC(JL)=1./PRMU(JL)
-      ZC1J(JL,KFLEV+1)=0.
- 111  CONTINUE
-C
-C*          1.3    AMOUNTS OF ABSORBERS
-C                  --------------------
-C
- 130  CONTINUE
-C
-      DO 131 JL= 1, KDLON
-      ZUD(JL,1) = 0.
-      ZUD(JL,2) = 0.
-      ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
-      ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
-      ZSIGO(JL) = PPSOL(JL)
-      ZCLEAR(JL)=1.
-      ZCLOUD(JL)=0.
- 131  CONTINUE
-C
-      DO 133 JK = 1 , KFLEV
-      JKP1 = JK + 1
-      JKL = KFLEV+1 - JK
-      JKLP1 = JKL+1
-      DO 132 JL = 1, KDLON
-      ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
-      ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
-      ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
-      ZSIGN(JL) = 100. * PPMB(JL,JKP1)
-      PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
-      ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
-      ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
-      ZDSCO2 = ZO175(JL) - ZN175(JL)
-      ZDSH2O = ZO190(JL) - ZN190(JL)
-      PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
-     .             * ZDSH2O * ZWH2O  * ZRTH
-      PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
-     .             * ZDSCO2 * RCO2 * ZRTU
-      ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
-      PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
-      PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
-      ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
-      ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
-      ZSIGO(JL) = ZSIGN(JL)
-      ZO175(JL) = ZN175(JL)
-      ZO190(JL) = ZN190(JL)
-C      
-      IF (NOVLP.EQ.1) THEN
-         ZCLEAR(JL)=ZCLEAR(JL)
-     S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
-     S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
-         ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
-         ZCLOUD(JL) = PCLDSW(JL,JKL)
-      ELSE IF (NOVLP.EQ.2) THEN
-         ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
-         ZC1J(JL,JKL) = ZCLOUD(JL)
-      ELSE IF (NOVLP.EQ.3) THEN
-         ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
-         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
-         ZC1J(JL,JKL) = ZCLOUD(JL)
+SUBROUTINE swu(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, paki, &
+    pcld, pclear, pdsig, pfact, prmu, psec, pud)
+
+  USE dimens_m
+  USE dimphy
+  USE clesphys
+  USE suphec_m
+  USE raddim
+  USE radepsi
+  USE radopt
+  IMPLICIT NONE
+
+  ! * ARGUMENTS:
+
+  DOUBLE PRECISION psct
+  ! IM ctes ds clesphys.h   DOUBLE PRECISION RCO2
+  DOUBLE PRECISION pcldsw(kdlon, kflev)
+  DOUBLE PRECISION ppmb(kdlon, kflev+1)
+  DOUBLE PRECISION ppsol(kdlon)
+  DOUBLE PRECISION prmu0(kdlon)
+  DOUBLE PRECISION pfrac(kdlon)
+  DOUBLE PRECISION ptave(kdlon, kflev)
+  DOUBLE PRECISION pwv(kdlon, kflev)
+
+  DOUBLE PRECISION paki(kdlon, 2)
+  DOUBLE PRECISION pcld(kdlon, kflev)
+  DOUBLE PRECISION pclear(kdlon)
+  DOUBLE PRECISION pdsig(kdlon, kflev)
+  DOUBLE PRECISION pfact(kdlon)
+  DOUBLE PRECISION prmu(kdlon)
+  DOUBLE PRECISION psec(kdlon)
+  DOUBLE PRECISION pud(kdlon, 5, kflev+1)
+
+  ! * LOCAL VARIABLES:
+
+  INTEGER iind(2)
+  DOUBLE PRECISION zc1j(kdlon, kflev+1)
+  DOUBLE PRECISION zclear(kdlon)
+  DOUBLE PRECISION zcloud(kdlon)
+  DOUBLE PRECISION zn175(kdlon)
+  DOUBLE PRECISION zn190(kdlon)
+  DOUBLE PRECISION zo175(kdlon)
+  DOUBLE PRECISION zo190(kdlon)
+  DOUBLE PRECISION zsign(kdlon)
+  DOUBLE PRECISION zr(kdlon, 2)
+  DOUBLE PRECISION zsigo(kdlon)
+  DOUBLE PRECISION zud(kdlon, 2)
+  DOUBLE PRECISION zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
+  INTEGER jl, jk, jkp1, jkl, jklp1, ja
+
+  ! * Prescribed Data:
+
+  DOUBLE PRECISION zpdh2o, zpdumg
+  SAVE zpdh2o, zpdumg
+  DOUBLE PRECISION zprh2o, zprumg
+  SAVE zprh2o, zprumg
+  DOUBLE PRECISION rtdh2o, rtdumg
+  SAVE rtdh2o, rtdumg
+  DOUBLE PRECISION rth2o, rtumg
+  SAVE rth2o, rtumg
+  DATA zpdh2o, zpdumg/0.8, 0.75/
+  DATA zprh2o, zprumg/30000., 30000./
+  DATA rtdh2o, rtdumg/0.40, 0.375/
+  DATA rth2o, rtumg/240., 240./
+  ! ------------------------------------------------------------------
+
+  ! *         1.     COMPUTES AMOUNTS OF ABSORBERS
+  ! -----------------------------
+
+
+  iind(1) = 1
+  iind(2) = 2
+
+
+  ! *         1.1    INITIALIZES QUANTITIES
+  ! ----------------------
+
+
+  DO jl = 1, kdlon
+    pud(jl, 1, kflev+1) = 0.
+    pud(jl, 2, kflev+1) = 0.
+    pud(jl, 3, kflev+1) = 0.
+    pud(jl, 4, kflev+1) = 0.
+    pud(jl, 5, kflev+1) = 0.
+    pfact(jl) = prmu0(jl)*pfrac(jl)*psct
+    prmu(jl) = sqrt(1224.*prmu0(jl)*prmu0(jl)+1.)/35.
+    psec(jl) = 1./prmu(jl)
+    zc1j(jl, kflev+1) = 0.
+  END DO
+
+  ! *          1.3    AMOUNTS OF ABSORBERS
+  ! --------------------
+
+
+  DO jl = 1, kdlon
+    zud(jl, 1) = 0.
+    zud(jl, 2) = 0.
+    zo175(jl) = ppsol(jl)**(zpdumg+1.)
+    zo190(jl) = ppsol(jl)**(zpdh2o+1.)
+    zsigo(jl) = ppsol(jl)
+    zclear(jl) = 1.
+    zcloud(jl) = 0.
+  END DO
+
+  DO jk = 1, kflev
+    jkp1 = jk + 1
+    jkl = kflev + 1 - jk
+    jklp1 = jkl + 1
+    DO jl = 1, kdlon
+      zrth = (rth2o/ptave(jl,jk))**rtdh2o
+      zrtu = (rtumg/ptave(jl,jk))**rtdumg
+      zwh2o = max(pwv(jl,jk), zepscq)
+      zsign(jl) = 100.*ppmb(jl, jkp1)
+      pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl)
+      zn175(jl) = zsign(jl)**(zpdumg+1.)
+      zn190(jl) = zsign(jl)**(zpdh2o+1.)
+      zdsco2 = zo175(jl) - zn175(jl)
+      zdsh2o = zo190(jl) - zn190(jl)
+      pud(jl, 1, jk) = 1./(10.*rg*(zpdh2o+1.))/(zprh2o**zpdh2o)*zdsh2o*zwh2o* &
+        zrth
+      pud(jl, 2, jk) = 1./(10.*rg*(zpdumg+1.))/(zprumg**zpdumg)*zdsco2*rco2* &
+        zrtu
+      zfppw = 1.6078*zwh2o/(1.+0.608*zwh2o)
+      pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw
+      pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw)
+      zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
+      zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
+      zsigo(jl) = zsign(jl)
+      zo175(jl) = zn175(jl)
+      zo190(jl) = zn190(jl)
+
+      IF (novlp==1) THEN
+        zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( &
+          zcloud(jl),1.-zepsec))
+        zc1j(jl, jkl) = 1.0 - zclear(jl)
+        zcloud(jl) = pcldsw(jl, jkl)
+      ELSE IF (novlp==2) THEN
+        zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl))
+        zc1j(jl, jkl) = zcloud(jl)
+      ELSE IF (novlp==3) THEN
+        zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl))
+        zcloud(jl) = 1.0 - zclear(jl)
+        zc1j(jl, jkl) = zcloud(jl)
       END IF
- 132  CONTINUE
- 133  CONTINUE
-      DO 134 JL=1, KDLON
-      PCLEAR(JL)=1.-ZC1J(JL,1)
- 134  CONTINUE
-      DO 136 JK=1,KFLEV
-      DO 135 JL=1, KDLON
-      IF (PCLEAR(JL).LT.1.) THEN
-         PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
+    END DO
+  END DO
+  DO jl = 1, kdlon
+    pclear(jl) = 1. - zc1j(jl, 1)
+  END DO
+  DO jk = 1, kflev
+    DO jl = 1, kdlon
+      IF (pclear(jl)<1.) THEN
+        pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl))
       ELSE
-         PCLD(JL,JK)=0.
+        pcld(jl, jk) = 0.
       END IF
- 135  CONTINUE
- 136  CONTINUE           
-C      
-C
-C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
-C                 -----------------------------------------------
-C
- 140  CONTINUE
-C
-      DO 142 JA = 1,2
-      DO 141 JL = 1, KDLON
-      ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
- 141  CONTINUE
- 142  CONTINUE
-C
-      CALL SWTT1(2, 2, IIND, ZUD, ZR)
-C
-      DO 144 JA = 1,2
-      DO 143 JL = 1, KDLON
-      PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
- 143  CONTINUE
- 144  CONTINUE
-C
-C
-C     ------------------------------------------------------------------
-C
-      RETURN
-      END
+    END DO
+  END DO
+
+
+  ! *         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+  ! -----------------------------------------------
+
+
+  DO ja = 1, 2
+    DO jl = 1, kdlon
+      zud(jl, ja) = zud(jl, ja)*psec(jl)
+    END DO
+  END DO
+
+  CALL swtt1(2, 2, iind, zud, zr)
+
+  DO ja = 1, 2
+    DO jl = 1, kdlon
+      paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja)
+    END DO
+  END DO
+
+END SUBROUTINE swu