Intel® Fortran Compiler
Build applications that can scale for the future with optimized code designed for Intel® Xeon® and compatible processors.
28456 Discussions

Equivalence

Luis_Thiago_L_
Beginner
‎06-12-2017 02:33 PM
443 Views

Hello,

I`m trying replace the equivalence in my code. Example:

    SUBROUTINE SPA88 (                                                                                                                      &
    & EXCTS   , CTSO3   , GXCTS   , SORC    , CSOUR   , CLDFAC  , TEMP    , PRESS   , VAR1         ,   &
    & VAR2     , P            , DELP      , DELP2   , TOTVO2  , TO3SP   , TO3SPC  , CO2SP1  , CO2SP2   ,   &
    & CO2SP)
!--------------------------------------------------------------------------------------------------
    USE PARMETA
    USE HCON
    USE PHYCON
    USE RNDDTA
!
    INCLUDE "MPP.h"
!
#include "sp.h"
!
    PARAMETER (L=LM)
    PARAMETER (IMAX=IM              , NCOL=IMAX)
    PARAMETER (NBLX=47)
    PARAMETER (NBLM=NBLY-1)
    PARAMETER (LP1=L+1               , LP2=L+2        , LP3=L+3)
    PARAMETER (LM1=L-1                , LM2=L-2        , LM3=L-3)
    PARAMETER (LL=2*L                   , LLP1=LL+1     , LLP2=LL+2, LLP3=LL+3)
    PARAMETER (LLM1=LL-1             , LLM2=LL-2     , LLM3=LL-3)
    PARAMETER (LP1M=LP1*LP1      , LP1M1=LP1M-1)
    PARAMETER (LP1V=LP1*(1+2*L/2))
    PARAMETER (LP121=LP1*NBLY)
    PARAMETER (LL3P=3*L+2)
    PARAMETER (NB=12)
    PARAMETER (INLTE=3                 ,INLTEP=INLTE+1  , NNLTE=56)
    PARAMETER (LP1I=IMAX*LP1      ,LLP1I=IMAX*LLP1, LL3PI=IMAX*LL3P)
    PARAMETER (NB1=NB-1)
    PARAMETER (KO2=12)
    PARAMETER (KO21=KO2+1         ,KO2M=KO2-1)
!
    DIMENSION SORC  (IDIM1:IDIM2, LP1 , NBLY), CSOUR (IDIM1:IDIM2, LP1)
    DIMENSION CLDFAC(IDIM1:IDIM2, LP1 , LP1)
    DIMENSION TEMP(IDIM1:IDIM2, LP1)       , PRESS (IDIM1:IDIM2, LP1)
    DIMENSION  VAR1(IDIM1:IDIM2, L)           ,   VAR2  (IDIM1:IDIM2, L)
    DIMENSION       P(IDIM1:IDIM2, LP1)        ,   DELP  (IDIM1:IDIM2, L)  ,  DELP2 (IDIM1:IDIM2, L)
!
    DIMENSION TOTVO2(IDIM1:IDIM2, LP1)       , TO3SPC(IDIM1:IDIM2, L)  ,  TO3SP (IDIM1:IDIM2, LP1)
!
    DIMENSION CO2SP1(IDIM1:IDIM2, LP1)       , CO2SP2(IDIM1:IDIM2, LP1),  CO2SP (IDIM1:IDIM2, LP1)
!
    DIMENSION EXCTS (IDIM1:IDIM2, L)         , CTSO3 (IDIM1:IDIM2, L)  , GXCTS (IDIM1:IDIM2)
!
    DIMENSION PHITMP(IDIM1:IDIM2, L)         , PSITMP(IDIM1:IDIM2, L)  ,              &
    &         TT    (IDIM1:IDIM2, L)         ,                                                                    &
    &         FAC1  (IDIM1:IDIM2, L)         , FAC2  (IDIM1:IDIM2, L)  ,                           &
    &         CTMP  (IDIM1:IDIM2, LP1)       , X     (IDIM1:IDIM2, L)  ,                          &
    &         Y     (IDIM1:IDIM2, L)         ,                                                    &
    &         TOPM  (IDIM1:IDIM2, L)         , TOPPHI(IDIM1:IDIM2, L)  ,                          &
    &         CTMP3 (IDIM1:IDIM2, LP1)       , CTMP2 (IDIM1:IDIM2, LP1)
!
    DIMENSION F     (IDIM1:IDIM2, L)         , FF    (IDIM1:IDIM2, L)  ,                          &
    &         AG    (IDIM1:IDIM2, L)         , AGG   (IDIM1:IDIM2, L)
!
!    EQUIVALENCE (F , AG , PHITMP)
!    EQUIVALENCE (FF, AGG, PSITMP)
!--------------------
! EQUIVALENCE REPLACE
!--------------------
    DO I=1,L
        AG(IDIM1:IDIM2,I) = TRANSFER( F(IDIM1:IDIM2,L),    AG(IDIM1:IDIM2,I))
    END DO
!
    DO I=1,L
    PHITMP(IDIM1:IDIM2,I) = TRANSFER( F(IDIM1:IDIM2,L),PHITMP(IDIM1:IDIM2,I))
    END DO
!
    DO I=1,L
       AGG(IDIM1:IDIM2,I) = TRANSFER(FF(IDIM1:IDIM2,L),   AGG(IDIM1:IDIM2,I))
    END DO
!
    DO I=1,L
    PSITMP(IDIM1:IDIM2,I) = TRANSFER(FF(IDIM1:IDIM2,L),PSITMP(IDIM1:IDIM2,I))
    END DO
!--------------------------------------------------------------------------------------------------
! COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM
!--------------------------------------------------------------------------------------------------
    DO 101 K=1,L
        DO 101 I=MYIS,MYIE
            X(I,K) = TEMP(I,K) - H25E2
            Y(I,K) =    X(I,K) * X(I,K)
    101 END DO
!--------------------------------------------------------------------------------------------------
! INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE
! TRANSMISSION FCTNS AT THE TOP.
!--------------------------------------------------------------------------------------------------
    DO 345 I=MYIS,MYIE
        CTMP (I,1) = ONE
        CTMP2(I,1) = 1.
        CTMP3(I,1) = 1.
    345 END DO
!--------------------------------------------------------------------------------------------------
!***BEGIN LOOP ON FREQUENCY BANDS (1)***
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 1 (COMBINED BAND 1)
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 301 K=1,L
        DO 301 I=MYIS,MYIE
                  F(I,K) =  H44194M2  * (APCM   (1)    * X  (I,K)  + BPCM(1)  * Y(I,K))
                 FF(I,K) =  H44194M2  * (ATPCM  (1)    * X  (I,K)  + BTPCM(1) * Y(I,K))
                 AG(I,K) = (H1P41819  + F       (I,K)) * F  (I,K)  + ONE
                AGG(I,K) = (H1P41819  + FF      (I,K)) * FF (I,K)  + ONE
             PHITMP(I,K) =  VAR1(I,K) * (((( AG (I,K)  * AG (I,K))  ** 2) ** 2) **2)
             PSITMP(I,K) =  VAR2(I,K) * (((( AGG(I,K)  * AGG(I,K))  ** 2) ** 2) **2)
    301 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 315 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    315 END DO
    DO 319 K=2,L
        DO 317 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        317 END DO
    319 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 321 K=1,L
        DO 321 I=MYIS,MYIE
            FAC1(I,K)   = ACOMB(1)    *   TOPM(I,K)
            FAC2(I,K)   = FAC1 (I,K)  *   TOPM(I,K) / (BCOMB(1) * TOPPHI(I,K))
              TT(I,K)   = EXP  (HM1EZ *   FAC1(I,K) / SQRT  (1. + FAC2  (I,K)))
            CTMP(I,K+1) = TT   (I,K)  * CLDFAC(I,K+1,1)
    321 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 353 K=1,L
        DO 353 I=MYIS,MYIE
            EXCTS(I,K) = SORC(I,K,1) * (CTMP(I,K+1) - CTMP(I,K))
    353 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 361 I=MYIS,MYIE
        GXCTS(I) =  CLDFAC(I,LP1,1) * ( TT(I,L)      *  SORC(I,L,1)                               &
    &            + (HAF             * DELP(I,L)      * (  TT(I,LM1)    * (   P(I,LP1)             &
    &            - PRESS  (I,L))    + TT  (I,L)      * (   P(I,LP1)    + PRESS(I,L)               &
    &            - TWO              * P   (I,L))))   * (SORC(I,LP1,1)  -  SORC(I,L,1)))
    361 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 2 (COMBINED BAND 2)
!--------------------------------------------------------------------------------------------------
!
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 401 K=1,L
        DO 401 I=MYIS,MYIE
                 F(I,K) =  H44194M2  * (   APCM(2)    *   X(I,K)  + BPCM (2) * Y(I,K))
                FF(I,K) =  H44194M2  * (  ATPCM(2)    *   X(I,K)  + BTPCM(2) * Y(I,K))
                AG(I,K) = (H1P41819  +        F(I,K)) *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819  +       FF(I,K)) *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K) * ((((  AG(I,K)  *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K) * (((( AGG(I,K)  * AGG(I,k)) ** 2) ** 2) ** 2)
    401 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 415 I=MYIS,MYIE
        TOPM  (I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    415 END DO
    DO 419 K=2,L
        DO 417 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        417 END DO
    419 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 421 K=1,L
        DO 421 I=MYIS,MYIE
            FAC1(I,K)   = ACOMB(2)    *   TOPM(I,K)
            FAC2(I,K)   =  FAC1(I,K)  *   TOPM(I,K) / (BCOMB(2) * TOPPHI(I,K))
              TT(I,K)   =   EXP(HM1EZ *   FAC1(I,K) / SQRT  (1. + FAC2  (I,K)))
            CTMP(I,K+1) =    TT(I,K)  * CLDFAC(I,K+1,1)
    421 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------  
    DO 453 K=1,L
        DO 453 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K)   + SORC(I,K,2) * (CTMP(I,K+1) - CTMP(I,K))
    453 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------   
    DO 461 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)         + CLDFAC(I,LP1,1) * (  TT(I,L)      *  SORC(I,L,2)            &
    &            + (HAF             *   DELP(I,L)     * (  TT(I,LM1)    * (   P(I,LP1)            &
    &            - PRESS(I,L))      +     TT(I,L)     * (   P(I,LP1)    + PRESS(I,L)              &
    &            - TWO              *      P(I,L))))  * (SORC(I,LP1, 2) -  SORC(I,L,2)))
    461 END DO
!
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 3 (COMBINED BAND 3)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 501 K=1,L
        DO 501 I=MYIS,MYIE
                 F(I,K) =  H44194M2  * (   APCM(3)    *   X(I,K)  + BPCM (3)   * Y(I,K))
                FF(I,K) =  H44194M2  * (  ATPCM(3)    *   X(I,K)  + BTPCM(3)   * Y(I,K))
                AG(I,K) = (H1P41819  +        F(I,K)) *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819  +       FF(I,K)) *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K) * ((((  AG(I,K)  *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K) * (((( AGG(I,K)  * AGG(I,K)) ** 2) ** 2) ** 2)
    501 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 515 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    515 END DO
    DO 519 K=2,L
        DO 517 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        517 END DO
    519 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 521 K=1,L
        DO 521 I=MYIS,MYIE
            FAC1(I,K)   = ACOMB(3)    *   TOPM(I,K)
            FAC2(I,K)   =  FAC1(I,K)  *   TOPM(I,K)      / (BCOMB(3) * TOPPHI(I,K))
              TT(I,K)   =   EXP(HM1EZ *   FAC1(I,K)      / SQRT  (1. +   FAC2(I,K)))
            CTMP(I,K+1) =    TT(I,K)  * CLDFAC(I,K+1,1)
    521 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 553 K=1,L
        DO 553 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,3) * (CTMP(I,K+1) - CTMP(I,K))
    553 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------  
    DO 561 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)       + CLDFAC(I,LP1, 1) *  (TT(I,L)   *  SORC(I,L,3)                 &
    &            + (HAF           *   DELP(I,L)      * ( TT(I,LM1) * (   P(I,LP1)                 &
    &            - PRESS(I,L))   +      TT(I,L)      * (  P(I,LP1) + PRESS(I,L)    - TWO          &
    &            *     P(I,L)))) * (  SORC(I,LP1,3)  - SORC(I,L,3)))
    561 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 4 (COMBINED BAND 4)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 601 K=1,L
        DO 601 I=MYIS,MYIE
                 F(I,K) =  H44194M2   * (  APCM(4)     *   X(I,K)  + BPCM (4)    * Y(I,K))
                FF(I,K) =  H44194M2   * ( ATPCM(4)     *   X(I,K)  + BTPCM(4)    * Y(I,K))
                AG(I,K) = (H1P41819   +       F(I,K))  *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819   +      FF(I,K))  *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K)  * ((((  AG(I,K)  *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K)  * (((( AGG(I,K)  * AGG(I,K)) ** 2) ** 2) ** 2)
    601 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 615 I=MYIS,MYIE
        TOPM  (I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    615 END DO
    DO 619 K=2,L
        DO 617 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        617 END DO
    619 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 621 K=1,L
        DO 621 I=MYIS,MYIE
            FAC1(I,K)   = ACOMB(4)    *   TOPM(I,K)
            FAC2(I,K)   =  FAC1(I,K)  *   TOPM(I,K)      / (BCOMB(4) * TOPPHI(I,K))
              TT(I,K)   =   EXP(HM1EZ *   FAC1(I,K)      / SQRT  (1. + FAC2  (I,K)))
            CTMP(I,K+1) =    TT (I,K) * CLDFAC(I,K+1,1)
    621 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 653 K=1,L
        DO 653 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,4) * (CTMP(I,K+1) - CTMP(I,K))
    653 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 661 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)     + CLDFAC(I,LP1,1) * (  TT(I,L)     *  SORC(I,L,4)                 &
    &            + (HAF         *   DELP(I,L)     * (  TT(I,LM1)   * (   P(I,LP1)                 &
    &            - PRESS(I,L))  +     TT(I,L)     * (   P(I,LP1)   + PRESS(I,L)                   &
    &            - TWO          *      P(I,L))))  * (SORC(I,LP1,4) -  SORC(I,L,4)))
    661 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 5 (COMBINED BAND 5)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 701 K=1,L
        DO 701 I=MYIS,MYIE
                 F(I,K) =  H44194M2   * (   APCM(5)    *   X(I,K)  +  BPCM(5)    * Y(I,K))
                FF(I,K) =  H44194M2   * (  ATPCM(5)    *   X(I,K)  + BTPCM(5)    * Y(I,K))
                AG(I,K) = (H1P41819   +        F(I,K)) *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819   +       FF(I,K)) *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K)  * ((((  AG (I,K) *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K)  * (((( AGG(I,K)  * AGG(I,K)) ** 2) ** 2) ** 2)
    701 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 715 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    715 END DO
    DO 719 K=2,L
        DO 717 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        717 END DO
    719 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 721 K=1,L
        DO 721 I=MYIS,MYIE
            FAC1(I,K)   =  ACOMB(5)     *   TOPM(I,K)
            FAC2(I,K)   =   FAC1(I,K)   *   TOPM(I,K)   / (BCOMB(5)  * TOPPHI(I,K))
              TT(I,K)   =    EXP(HM1EZ  * ( FAC1(I,K)   /   SQRT(ONE +   FAC2(I,K))               &
    &                   + BETACM(5)     * TOTVO2(I,K+1) * SKO2D))
!             
            CTMP(I,K+1) =     TT(I,K)   * CLDFAC(I,K+1,1)
    721 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 753 K=1,L
        DO 753 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,5) * (CTMP(I,K+1) - CTMP(I,K))
    753 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 761 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)         + CLDFAC(I,LP1,1)  * (  TT(I,L)      *  SORC(I,L,5)          &
    &            + (HAF             *   DELP(I,L)      * (  TT(I,LM1)    * (   P(I,LP1)           &  
    &            - PRESS(I,L))      +     TT(I,L)      * (   P(I,LP1)    + PRESS(I,L)             &
    &            - TWO              *      P(I,L))))   * (SORC(I,LP1,5)  -  SORC(I,L,5)))
    761 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 6 (COMBINED BAND 6)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED  OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 801 K=1,L
        DO 801 I=MYIS,MYIE
                 F(I,K) =  H44194M2   * (   APCM(6)     *   X(I,K)  +  BPCM(6)    * Y(I,K))
                FF(I,K) =  H44194M2   * (  ATPCM(6)     *   X(I,K)  + BTPCM(6)    * Y(I,K))
                AG(I,K) = (H1P41819   +        F(I,K))  *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819   +       FF(I,K))  *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K)  * ((((  AG(I,K)   *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K)  * (((( AGG(I,K)   * AGG(I,K)) ** 2) ** 2) ** 2)
    801 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 815 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    815 END DO
    DO 819 K=2,L
        DO 817 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        817 END DO
    819 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 821 K=1,L
        DO 821 I=MYIS,MYIE
            FAC1(I,K)   =  ACOMB(6)    *   TOPM(I,K)
            FAC2(I,K)   =   FAC1(I,K)  *   TOPM(I,K)   / (BCOMB(6)  * TOPPHI(I,K))
              TT(I,K)   =    EXP(HM1EZ * ( FAC1(I,K)   /   SQRT(ONE +   FAC2(I,K))                &
    &                   + BETACM(6)    * TOTVO2(I,K+1) * SKO2D))
!
            CTMP(I,K+1) =     TT(I,K)  * CLDFAC(I,K+1,1)
    821 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 853 K=1,L
        DO 853 I=MYIS,MYIE
            EXCTS(I,K)= EXCTS(I,K) + SORC(I,K,6) * (CTMP(I,K+1) - CTMP(I,K))
    853 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 861 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)        + CLDFAC(I,LP1,1) * ( TT(I,L)   *  SORC(I,L,6)                 &
    &            + ( HAF           *   DELP(I,L)     * ( TT(I,LM1) * (   P(I,LP1)                 &
    &            - PRESS(I,L))     +     TT(I,L)     * (  P(I,LP1) + PRESS(I,L)   - TWO           &
    &            *     P(I,L))))   * ( SORC(I,LP1,6) - SORC(I,L,6)))
    861 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 7 (COMBINED BAND 7)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 901 K=1,L
        DO 901 I=MYIS,MYIE
                 F(I,K) =  H44194M2   * (   APCM(7)    *   X(I,K)   + BPCM (7) * Y(I,K))
                FF(I,K) =  H44194M2   * (  ATPCM(7)    *   X(I,K)   + BTPCM(7) * Y(I,K))
                AG(I,K) = (H1P41819   +        F(I,K)) *   F(I,K)   + ONE
               AGG(I,K) = (H1P41819   +       FF(I,K)) *  FF(I,K)   + ONE
            PHITMP(I,K) =  VAR1(I,K)  * ((((  AG(I,K)  *  AG (I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K)  * (((( AGG(I ,K) * AGG(I,K))  ** 2) ** 2) ** 2)
    901 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 915 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    915 END DO
    DO 919 K=2,L
        DO 917 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        917 END DO
    919 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 921 K=1,L
        DO 921 I=MYIS,MYIE
            FAC1(I,K)   =   ACOMB(7)    *   TOPM(I,K)
            FAC2(I,K)   =    FAC1(I,K)  *   TOPM(I,K)   / (BCOMB(7)  * TOPPHI(I,K))
              TT(I,K)   =     EXP(HM1EZ * ( FAC1(I,K)   /   SQRT(ONE +   FAC2(I,K))               &
    &                    + BETACM(7)    * TOTVO2(I,K+1) * SKO2D))
!
            CTMP(I,K+1) =      TT(I,K)  * CLDFAC(I,K+1,1)
    921 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 953 K=1,L
        DO 953 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,7) * (CTMP(I,K+1) - CTMP(I,K))
    953 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 961 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)     + CLDFAC(I,LP1,1) * (  TT(I,L)     *  SORC(I,L,7)                 &  
    &            + (HAF         *   DELP(I,L)     * (  TT(I,LM1)   * (   P(I,LP1)                 &
    &            - PRESS(I,L))  +     TT(I,L)     * (   P(I,LP1)   + PRESS(I,L)                   &
    &            - TWO          *      P(I,L))))  * (SORC(I,LP1,7) -  SORC(I,L,7)))
    961 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 8 (COMBINED BAND 8)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 1001 K=1,L
        DO 1001 I=MYIS,MYIE
                 F(I,K) =  H44194M2   * (   APCM(8)    *   X(I,K)  + BPCM (8)    * Y(I,K))
                FF(I,K) =  H44194M2   * (  ATPCM(8)    *   X(I,K)  + BTPCM(8)    * Y(I,K))
                AG(I,K) = (H1P41819   +        F(I,K)) *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819   +       FF(I,K)) *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K)  * ((((  AG(I,K)  *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K)  * (((( AGG(I,K)  * AGG(I,K)) ** 2) ** 2) ** 2)
    1001 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 1015 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    1015 END DO
    DO 1019 K=2,L
        DO 1017 I=MYIS,MYIE
            TOPM  (I,K) = TOPM  (I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        1017 END DO
    1019 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 1021 K=1,L
        DO 1021 I=MYIS,MYIE
            FAC1(I,K)   =  ACOMB(8)    *   TOPM(I,K)
            FAC2(I,K)   =   FAC1(I,K)  *   TOPM(I,K)   / (BCOMB(8)  * TOPPHI(I,K))
              TT(I,K)   =    EXP(HM1EZ * ( FAC1(I,K)   /   SQRT(ONE +   FAC2(I,K))                &
    &                   + BETACM(8)    * TOTVO2(I,K+1) * SKO2D))
!
            CTMP(I,K+1) =     TT(I,K)  * CLDFAC(I,K+1,1)
    1021 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1053 K=1,L
        DO 1053 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K, 8) * (CTMP(I,K+1) - CTMP(I,K))
    1053 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1061 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)    + CLDFAC(I,LP1,1)  * (  TT(I,L)      *  SORC(I,L,8)                &  
    &            + (HAF        *   DELP(I,L)      * (  TT(I,LM1)    * (   P(I,LP1)                &  
    &            - PRESS(I,L)) +     TT(I,L)      * (   P(I,LP1)    + PRESS(I,L)                  &
    &            - TWO         *      P(I,L))))   * (SORC(I,LP1,8)  -  SORC(I,L,8)))
1061 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 1101 K=1,L
        DO 1101 I=MYIS,MYIE
                 F(I,K) =  H44194M2   * (   APCM(9)    *   X(I,K)  + BPCM (9)    * Y(I,K))
                FF(I,K) =  H44194M2   * (  ATPCM(9)    *   X(I,K)  + BTPCM(9)    * Y(I,K))
                AG(I,K) = (H1P41819   +        F(I,K)) *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819   +       FF(I,K)) *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K)  * ((((  AG (I,K) *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K)  * (((( AGG(I,K)  * AGG(I,K)) ** 2) ** 2) ** 2)
    1101 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 1115 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    1115 END DO
    DO 1119 K=2,L
        DO 1117 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        1117 END DO
    1119 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 1121 K=1,L
        DO 1121 I=MYIS,MYIE
            FAC1(I,K)   =  ACOMB(9)    *   TOPM(I,K)
            FAC2(I,K)   =   FAC1(I,K)  *   TOPM(I,K)   / (BCOMB(9)  * TOPPHI(I,K))
              TT(I,K)   =    EXP(HM1EZ * ( FAC1(I,K)   /   SQRT(ONE +   FAC2(I,K))                &
    &                   + BETACM(9)    * TOTVO2(I,K+1) * SKO2D))    * CO2SP1(I,K+1)
!             
            CTMP(I,K+1) =     TT(I,K)  * CLDFAC(I,K+1,1)
    1121 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1153 K=1,L
        DO 1153 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K, 9) * (CTMP(I,K+1) - CTMP(I,K))
    1153 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1161 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)     + CLDFAC(I,LP1, 1) * (  TT(I,L)      *  SORC(I,L,9)               &
    &            + (HAF         *   DELP(I,L)      * (  TT(I,LM1)    * (   P(I,LP1)               &
    &            - PRESS(I,L))  +     TT(I,L)      * (   P(I,LP1)    + PRESS(I,L)                 &  
    &            - TWO          *      P(I,L))))   * (SORC(I,LP1,9)  -  SORC(I,L,9)))
1161 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 1201 K=1,L
        DO 1201 I=MYIS,MYIE
                 F(I,K) =  H44194M2   * (   APCM(10)   *   X(I,K) +  BPCM(10)    * Y(I,K))
                FF(I,K) =  H44194M2   * (  ATPCM(10)   *   X(I,K) + BTPCM(10)    * Y(I,K))
                AG(I,K) = (H1P41819   +        F(I,K)) *   F(I,K) + ONE
               AGG(I,K) = (H1P41819   +       FF(I,K)) *  FF(I,K) + ONE
            PHITMP(I,K) =  VAR1(I,K)  * ((((  AG (I,K) *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K)  * (((( AGG(I,K)  * AGG(I,K)) ** 2) ** 2) ** 2)
    1201 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 1215 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    1215 END DO
    DO 1219 K=2,L
        DO 1217 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        1217 END DO
    1219 END DO
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
    DO 1221 K=1,L
        DO 1221 I=MYIS,MYIE
             FAC1(I,K) = ACOMB(10)   *   TOPM(I,K)
             FAC2(I,K) =  FAC1(I,K)  *   TOPM(I,K)  / (BCOMB(10) * TOPPHI(I,K))
               TT(I,K) =   EXP(HM1EZ *  (FAC1(I,K)  /   SQRT(ONE +   FAC2(I,K))                   &
    &                  + BETACM(10)  * TOTVO2(I,K+1) * SKO2D))   * CO2SP2(I,K+1)
!               
            CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
    1221 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1253 K=1,L
        DO 1253 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,10) * (CTMP(I,K+1) - CTMP(I,K))
    1253 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1261 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)    + CLDFAC(I,LP1,1) * (  TT(I,L)      *  SORC(I,L,10)                &
    &             +(HAF        *   DELP(I,L)     * (  TT(I,LM1)    * (   P(I,LP1)                 &
    &             -PRESS(I,L)) +     TT(I,L)     * (   P(I,LP1)    + PRESS(I,L)                   &
    &             -TWO         *      P(I,L))))  * (SORC(I,LP1,10) -  SORC(I,L,10)))
1261 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 11 (800-900 CM-1)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 1301 K=1,L
        DO 1301 I=MYIS,MYIE
                 F(I,K) =  H44194M2  * ( APCM(11)   *   X(I,K)  +  BPCM(11)   * Y(I,K))
                FF(I,K) =  H44194M2  * (ATPCM(11)   *   X(I,K)  + BTPCM(11)   * Y(I,K))
                AG(I,K) = (H1P41819  +      F(I,K)) *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819  +     FF(I,K)) *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K) *(((( AG(I,K)  *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K) *(((( AGG(I,K) * AGG(I,K)) ** 2) ** 2) ** 2)
    1301 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 1315 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    1315 END DO
    DO 1319 K=2,L
        DO 1317 I=MYIS,MYIE
              TOPM(I,K) =  TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) =TOPPHI(I,K-1) + PSITMP(I,K)
        1317 END DO
    1319 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 1321 K=1,L
        DO 1321 I=MYIS,MYIE
            FAC1(I,K) =  ACOMB(11)    *   TOPM(I,K)
            FAC2(I,K) =   FAC1(I,K)   *   TOPM(I,K)   / (BCOMB(11) * TOPPHI(I,K))
              TT(I,K) =    EXP(HM1EZ  * ( FAC1(I,K)   /   SQRT(ONE +   FAC2(I,K))                 &
    &                 + BETACM(11)    * TOTVO2(I,K+1) * SKO2D))
!               
            CTMP(I,K+1) =   TT(I,K)   * CLDFAC(I,K+1,1)
    1321 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1353 K=1,L
        DO 1353 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,11) * (CTMP(I,K+1) - CTMP(I,K))
    1353 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1361 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)    + CLDFAC(I,LP1,1) * (  TT(I,L)      *  SORC(I,L,11)                &
    &            + (HAF        *   DELP(I,L)     * (  TT(I,LM1)    * (   P(I,LP1)                 &
    &            - PRESS(I,L)) +     TT(I,L)     * (   P(I,LP1)    + PRESS(I,L)                   &
    &            - TWO         *      P(I,L))))  * (SORC(I,LP1,11) -  SORC(I,L,11)))
1361 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 12 (900-990 CM-1)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO  
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 1401 K=1,L
        DO 1401 I=MYIS,MYIE
                 F(I,K) =  H44194M2  * (  APCM(12)   *   X(I,K) +  BPCM(12)    * Y(I,K))
                FF(I,K) =  H44194M2  * ( ATPCM(12)   *   X(I,K) + BTPCM(12)    * Y(I,K))
                AG(I,K) = (H1P41819  +       F(I,K)) *   F(I,K) + ONE
               AGG(I,K) = (H1P41819  +      FF(I,K)) *  FF(I,K) + ONE
            PHITMP(I,K) =  VAR1(I,K) *((((  AG(I,K)  *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K) *(((( AGG(I,K)  * AGG(I,K)) ** 2) ** 2) ** 2)
    1401 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 1415 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    1415 END DO
    DO 1419 K=2,L
        DO 1417 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        1417 END DO
    1419 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 1421 K=1,L
        DO 1421 I=MYIS,MYIE
            FAC1(I,K)   =  ACOMB(12)   *   TOPM(I,K)
            FAC2(I,K)   =   FAC1(I,K)  *   TOPM(I,K)   / (BCOMB(12) * TOPPHI(I,K))
              TT(I,K)   =    EXP(HM1EZ * ( FAC1(I,K)   /   SQRT(ONE +   FAC2(I,K))                &
    &                   + BETACM(12)   * TOTVO2(I,K+1) * SKO2D))
!               
            CTMP(I,K+1) =     TT(I,K)  * CLDFAC(I,K+1,1)
    1421 END DO
!--------------------------------------------------------------------------------------------------
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1453 K=1,L
        DO 1453 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,12) * (CTMP(I,K+1) - CTMP(I,K))
    1453 END DO
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
    DO 1461 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)    + CLDFAC(I,LP1,1) * (  TT(I,L)      * SORC(I,L,12)                 &
    &            + (HAF        *   DELP(I,L)     * (  TT(I,LM1)    * (  P(I,LP1)                  &
    &            - PRESS(I,L)) +     TT(I,L)     * (   P(I,LP1)    + PRESS(I,L)                   &
    &            - TWO         *      P(I,L))))  * (SORC(I,LP1,12) -  SORC(I,L,12)))
1461 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3))
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO   
! COMPUTE TEMPERATURE-CORRECTED !   OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 1501 K=1,L
        DO 1501 I=MYIS,MYIE
                 F(I,K) =  H44194M2  *(   APCM(13)   *   X(I,K)  + BPCM(13)    * Y(I,K))
                FF(I,K) =  H44194M2  *(  ATPCM(13)   *   X(I,K)  + BTPCM(13)   * Y(I,K))
                AG(I,K) = (H1P41819  +       F(I,K)) *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819  +      FF(I,K)) *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K) * (((( AG(I,K)  *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K) * (((( AGG(I,K) * AGG(I,K)) ** 2) ** 2) ** 2)
    1501 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 1515 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    1515 END DO
    DO 1519 K=2,L
        DO 1517 I=MYIS,MYIE
              TOPM(I,K) =   TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K)
        1517 END DO
    1519 END DO
!--------------------------------------------------------------------------------------------------
!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 1521 K=1,L
        DO 1521 I=MYIS,MYIE
            FAC1(I,K)   =  ACOMB(13)   *   TOPM(I,K)
            FAC2(I,K)   =   FAC1(I,K)  *   TOPM(I,K)   / (BCOMB(13) * TOPPHI(I,K))
              TT(I,K)   =    EXP(HM1EZ * ( FAC1(I,K)   /   SQRT(ONE + FAC2(I,K))                  &
    &                   + BETACM(13)   * TOTVO2(I,K+1) * SKO2D      + TO3SPC(I,K)))
!               
            CTMP(I,K+1) =     TT(I,K)  * CLDFAC(I,K+1,1)
    1521 END DO
!--------------------------------------------------------------------------------------------------
!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1553 K=1,L
        DO 1553 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,13) * (CTMP(I,K+1) - CTMP(I,K))
    1553 END DO
!--------------------------------------------------------------------------------------------------
!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1561 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)    + CLDFAC(I,LP1,1) * (  TT(I,L)      *  SORC(I,L,13)                &  
    &            + (HAF        *   DELP(I,L)     * (  TT(I,LM1)    * (   P(I,LP1)                 &
    &            - PRESS(I,L)) +     TT(I,L)     * (   P(I,LP1)    + PRESS(I,L)                   &
    &            - TWO         *      P(I,L))))  * (SORC(I,LP1,13) -  SORC(I,L,13)))
1561 END DO
!--------------------------------------------------------------------------------------------------
! CALCULATION FOR BAND 14 (1070-1200 CM-1)
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY BY OPTICAL PATH (VAR1,VAR2) TO   
! COMPUTE TEMPERATURE-CORRECTED OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
!--------------------------------------------------------------------------------------------------
    DO 1601 K=1,L
        DO 1601 I=MYIS,MYIE
                 F(I,K) = H44194M2   * (   APCM(14)   *   X(I,K)  + BPCM(14)    * Y(I,K))
                FF(I,K) = H44194M2   * (  ATPCM(14)   *   X(I,K)  + BTPCM(14)   * Y(I,K))
                AG(I,K) = (H1P41819  +        F(I,K)) *   F(I,K)  + ONE
               AGG(I,K) = (H1P41819  +       FF(I,K)) *  FF(I,K)  + ONE
            PHITMP(I,K) =  VAR1(I,K) * ((((  AG(I,K)  *  AG(I,K)) ** 2) ** 2) ** 2)
            PSITMP(I,K) =  VAR2(I,K) * (((( AGG(I,K)  * AGG(I,K)) ** 2) ** 2) ** 2)
    1601 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
! P(K) (TOPM,TOPPHI)
!--------------------------------------------------------------------------------------------------
    DO 1615 I=MYIS,MYIE
          TOPM(I,1) = PHITMP(I,1)
        TOPPHI(I,1) = PSITMP(I,1)
    1615 END DO
    DO 1619 K=2,L
        DO 1617 I=MYIS,MYIE
              TOPM(I,K) =  TOPM(I,K-1) + PHITMP(I,K)
            TOPPHI(I,K) =TOPPHI(I,K-1) + PSITMP(I,K)
        1617 END DO
    1619 END DO
!--------------------------------------------------------------------------------------------------
! TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
!--------------------------------------------------------------------------------------------------
    DO 1621 K=1,L
        DO 1621 I=MYIS,MYIE
            FAC1(I,K)   =  ACOMB(14)   *   TOPM(I,K)
            FAC2(I,K)   =   FAC1(I,K)  *   TOPM(I,K)   / (BCOMB(14) * TOPPHI(I,K))
              TT(I,K)   =    EXP(HM1EZ * ( FAC1(I,K)   /   SQRT(ONE +   FAC2(I,K))                &
    &                   + BETACM(14)   * TOTVO2(I,K+1) * SKO2D))
!               
            CTMP(I,K+1) =     TT(I,K)  * CLDFAC(I,K+1,1)
    1621 END DO
!--------------------------------------------------------------------------------------------------
! EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1653 K=1,L
        DO 1653 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) + SORC(I,K,14) * (CTMP(I,K+1) - CTMP(I,K))
    1653 END DO
!--------------------------------------------------------------------------------------------------
! GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
!--------------------------------------------------------------------------------------------------
    DO 1661 I=MYIS,MYIE
        GXCTS(I) = GXCTS(I)    + CLDFAC(I,LP1,1) * (  TT(I,L)      *  SORC(I,L,14)                &
    &            + (HAF        *   DELP(I,L)     * (  TT(I,LM1)    * (   P(I,LP1)                 &
    &            - PRESS(I,L)) +     TT(I,L)     * (   P(I,LP1)    + PRESS(I,L)                   &
    &            - TWO         *      P(I,L))))  * (SORC(I,LP1,14) -  SORC(I,L,14)))
1661 END DO
!--------------------------------------------------------------------------------------------------
! OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND USING CTS FLUX AT THE BOTTOM   
! (CURRENT VALUE OF GXCTS). NOTE THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT
! BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS REDUCING COMPUTATIONS
!--------------------------------------------------------------------------------------------------
    DO 1731 K=1,L
        DO 1731 I=MYIS,MYIE
            GXCTS(I) = GXCTS(I) - EXCTS(I,K)
1731 END DO
!--------------------------------------------------------------------------------------------------
! NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE FACTOR (DELP) AND THE CONVERSION  
! FACTOR (RADCON)
!--------------------------------------------------------------------------------------------------
    DO 1741 K=1,L
        DO 1741 I=MYIS,MYIE
            EXCTS(I,K) = EXCTS(I,K) * RADCON * DELP(I,K)
    1741 END DO
!--------------------------------------------------------------------------------------------------
! THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT EXCTS HAS ITS APPROPRIATE VALUE.
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
! COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS (CTSO3)
!--------------------------------------------------------------------------------------------------
    DO 1711 K=1,L
        DO 1711 I=MYIS,MYIE
            CTMP2(I,K+1) = CO2SP(I,K+1) * CLDFAC(I,K+1,1)
            CTMP3(I,K+1) = TO3SP(I,K)   * CLDFAC(I,K+1,1)
    1711 END DO
    DO 1701 K=1,L
        DO 1701 I=MYIS,MYIE
           CTSO3(I,K) = RADCON       *   DELP(I,K)   * (CSOUR(I,K) * (CTMP2(I,K+1) - CTMP2(I,K))  &
    &                 + SORC(I,K,13) * (CTMP3(I,K+1) -  CTMP3(I,K)))
    1701 END DO
!
    RETURN
    END SUBROUTINE SPA88

However,  my equivalent variables are constant changing its values,

My question is, everytime any of this variables changes its value along the code i must do again the transfer function ?

Exist another easier way to do it ?

 

Thank you very much for your attention

0 Kudos

Link Copied

4 Replies
mecej4
Honored Contributor III
‎06-12-2017 04:12 PM
443 Views

Since you have not divulged the contents of the include files and the sources of the modules that are used, the following comments have to be somewhat vague and general.

TRANSFER and EQUIVALENCE are not equivalent. EQUIVALENCE is a declaration that results in the same memory being accessible with different variable names. Changing values using any of these names changes the values of all the variables that are equivalenced.

TRANSFER, on the other hand, is used in expressions that you may assign as values to variables. Only the variable to the left of the assignment operator '=' has the value changed. If you had n equivalenced variables in a set in the old program version, you may need n-1 assignments with TRANSFER to make corresponding assignments in the new version.  You will need to examine whether or not this has been done in your program. 

0 Kudos
Copy link
Luis_Thiago_L_
Beginner
‎06-12-2017 05:56 PM
443 Views

Sorry about not posting the full sources.

Its because my program is really big.

What I`m trying to do is convert all COMMON block into MODULES but in some parts I can`t use modules because its variables are used in EQUIVALENCES.

I`m trying to find the best way to replace them. 

0 Kudos
Copy link
mecej4
Honored Contributor III
‎06-12-2017 08:51 PM
443 Views

You can equivalence two or more module variables in the module declarations part. For example:

module xyz
   implicit none
   integer :: i1,i2,i3
   equivalence(i1,i3)
end module

Although eliminating COMMON and EQUIVALENCE is a worthwhile goal, there is no need to do both in one stroke.

What I am suggesting is to remove COMMON, while retaining EQUIVALENCE. After that has been successfully accomplished and your new program tested for correct functioning, you can focus your attention on removing the equivalenced variables, using TRANSFER or other strategies.

0 Kudos
Copy link
Reply

Community support is provided during standard business hours (Monday to Friday 7AM - 5PM PST). Other contact methods are available here.

Intel does not verify all solutions, including but not limited to any file transfers that may appear in this community. Accordingly, Intel disclaims all express and implied warranties, including without limitation, the implied warranties of merchantability, fitness for a particular purpose, and non-infringement, as well as any warranty arising from course of performance, course of dealing, or usage in trade.

For more complete information about compiler optimizations, see our Optimization Notice.