Ignore:
Timestamp:
Jul 23, 2024, 8:22:55 AM (2 months ago)
Author:
abarral
Message:

Handle DEBUG_IO in lmdz_cppkeys_wrapper.F90
Transform some files .F -> .[fF]90
[ne compile pas à cause de writefield_u non défini - en attente de réponse Laurent]

File:
1 edited

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/exner_hyb_loc_m.F90

    r5099 r5101  
    55contains
    66
    7   SUBROUTINE  exner_hyb_loc(ngrid, ps, p, pks,pk,pkf)
     7  SUBROUTINE  exner_hyb_loc(ngrid, ps, p, pks, pk, pkf)
    88
    99    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
    … …  
    1414
    1515    !   ************************************************************************
    16     !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
     16    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des
    1717    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
    1818    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
    … …  
    2626    !    ( voir note de Fr.Hourdin )  ,
    2727
    28     !    on determine successivement , du haut vers le bas des couches, les 
    29     !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
    30     !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 
     28    !    on determine successivement , du haut vers le bas des couches, les
     29    !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2),
     30    !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,
    3131    !     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
    32 
    3332
    3433    USE parallel_lmdz
    … …  
    3736    USE comconst_mod, ONLY: cpp, kappa, r, jmp1
    3837    USE comvert_mod, ONLY: preff
    39    
     38    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
     39
    4040    IMPLICIT NONE
    4141
    … …  
    4545
    4646    INTEGER  ngrid
    47     REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
    48     REAL, optional:: pkf(ijb_u:ije_u,llm)
    49     REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
    50     REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm)
     47    REAL p(ijb_u:ije_u, llmp1), pk(ijb_u:ije_u, llm)
     48    REAL, optional :: pkf(ijb_u:ije_u, llm)
     49    REAL ps(ijb_u:ije_u), pks(ijb_u:ije_u)
     50    REAL alpha(ijb_u:ije_u, llm), beta(ijb_u:ije_u, llm)
    5151
    5252    !    .... variables locales   ...
    5353
    5454    INTEGER l, ij
    55     REAL unpl2k,dellta
     55    REAL unpl2k, dellta
    5656
    57     INTEGER ije,ijb,jje,jjb
    58     logical,save :: firstcall=.true.
    59     !$OMP THREADPRIVATE(firstcall) 
    60     character(len=*),parameter :: modname="exner_hyb_loc"
     57    INTEGER ije, ijb, jje, jjb
     58    logical, save :: firstcall = .true.
     59    !$OMP THREADPRIVATE(firstcall)
     60    character(len = *), parameter :: modname = "exner_hyb_loc"
    6161
    62     !$OMP BARRIER           
     62    !$OMP BARRIER
    6363
    6464    ! Sanity check
    6565    if (firstcall) then
    66        ! sanity checks for Shallow Water case (1 vertical layer)
    67        if (llm==1) then
    68           if (kappa/=1) then
    69              call abort_gcm(modname, &
    70                   "kappa!=1 , but running in Shallow Water mode!!",42)
    71           endif
    72           if (cpp/=r) then
    73              call abort_gcm(modname, &
    74                   "cpp!=r , but running in Shallow Water mode!!",42)
    75           endif
    76        endif ! of if (llm.eq.1)
     66      ! sanity checks for Shallow Water case (1 vertical layer)
     67      if (llm==1) then
     68        if (kappa/=1) then
     69          CALL abort_gcm(modname, &
     70                  "kappa!=1 , but running in Shallow Water mode!!", 42)
     71        endif
     72        if (cpp/=r) then
     73          CALL abort_gcm(modname, &
     74                  "cpp!=r , but running in Shallow Water mode!!", 42)
     75        endif
     76      endif ! of if (llm.eq.1)
    7777
    78        firstcall=.false.
     78      firstcall = .false.
    7979    endif ! of if (firstcall)
    8080
    … …  
    8484    if (llm==1) then
    8585
    86        ! Compute pks(:),pk(:),pkf(:)
    87        ijb=ij_begin
    88        ije=ij_end
    89        !$OMP DO SCHEDULE(STATIC)
    90        DO ij=ijb, ije
    91           pks(ij) = (cpp/preff) * ps(ij)
    92           pk(ij,1) = .5*pks(ij)
    93           if (present(pkf)) pkf(ij,1)=pk(ij,1)
    94        ENDDO
    95        !$OMP ENDDO
     86      ! Compute pks(:),pk(:),pkf(:)
     87      ijb = ij_begin
     88      ije = ij_end
     89      !$OMP DO SCHEDULE(STATIC)
     90      DO ij = ijb, ije
     91        pks(ij) = (cpp / preff) * ps(ij)
     92        pk(ij, 1) = .5 * pks(ij)
     93        if (present(pkf)) pkf(ij, 1) = pk(ij, 1)
     94      ENDDO
     95      !$OMP ENDDO
    9696
    97        !$OMP BARRIER
    98        if (present(pkf)) then
    99           jjb=jj_begin
    100           jje=jj_end
    101           CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
    102                2, 1, .TRUE., 1 )
    103        end if
     97      !$OMP BARRIER
     98      if (present(pkf)) then
     99        jjb = jj_begin
     100        jje = jj_end
     101        CALL filtreg_p (pkf, jjb_u, jje_u, jjb, jje, jmp1, llm, &
     102                2, 1, .TRUE., 1)
     103      end if
    104104
    105        ! our work is done, exit routine
    106        return
     105      ! our work is done, exit routine
     106      return
    107107    endif ! of if (llm.eq.1)
    108108
    109109    ! General case:
    110110
    111     unpl2k    = 1.+ 2.* kappa
     111    unpl2k = 1. + 2. * kappa
    112112
    113113    !     -------------
    … …  
    115115    !     -------------
    116116
    117     ijb=ij_begin
    118     ije=ij_end
     117    ijb = ij_begin
     118    ije = ij_end
    119119
    120120    !$OMP DO SCHEDULE(STATIC)
    121     DO   ij  = ijb, ije
    122        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
     121    DO   ij = ijb, ije
     122      pks(ij) = cpp * (ps(ij) / preff) ** kappa
    123123    ENDDO
    124124    !$OMP ENDDO
    … …  
    131131
    132132    !$OMP DO SCHEDULE(STATIC)
    133     DO     ij      = ijb,ije
    134        alpha(ij,llm) = 0.
    135        beta (ij,llm) = 1./ unpl2k
     133    DO     ij = ijb, ije
     134      alpha(ij, llm) = 0.
     135      beta (ij, llm) = 1. / unpl2k
    136136    ENDDO
    137137    !$OMP ENDDO NOWAIT
    … …  
    139139    !     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
    140140
    141     DO l = llm -1 , 2 , -1
     141    DO l = llm - 1, 2, -1
    142142
    143        !$OMP DO SCHEDULE(STATIC)
    144        DO ij = ijb, ije
    145           dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
    146           alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
    147           beta (ij,l)  =   p(ij,l  ) / dellta   
    148        ENDDO
    149        !$OMP ENDDO NOWAIT
     143      !$OMP DO SCHEDULE(STATIC)
     144      DO ij = ijb, ije
     145        dellta = p(ij, l) * unpl2k + p(ij, l + 1) * (beta(ij, l + 1) - unpl2k)
     146        alpha(ij, l) = - p(ij, l + 1) / dellta * alpha(ij, l + 1)
     147        beta (ij, l) = p(ij, l) / dellta
     148      ENDDO
     149      !$OMP ENDDO NOWAIT
    150150    ENDDO
    151151
    … …  
    154154
    155155    !$OMP DO SCHEDULE(STATIC)
    156     DO   ij   = ijb, ije
    157        pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / &
    158             (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
     156    DO   ij = ijb, ije
     157      pk(ij, 1) = (p(ij, 1) * pks(ij) - 0.5 * alpha(ij, 2) * p(ij, 2)) / &
     158              (p(ij, 1) * (1. + kappa) + 0.5 * (beta(ij, 2) - unpl2k) * p(ij, 2))
    159159    ENDDO
    160160    !$OMP ENDDO NOWAIT
    … …  
    163163
    164164    DO l = 2, llm
    165        !$OMP DO SCHEDULE(STATIC)
    166        DO   ij  = ijb, ije
    167           pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
    168        ENDDO
    169        !$OMP ENDDO NOWAIT       
     165      !$OMP DO SCHEDULE(STATIC)
     166      DO   ij = ijb, ije
     167        pk(ij, l) = alpha(ij, l) + beta(ij, l) * pk(ij, l - 1)
     168      ENDDO
     169      !$OMP ENDDO NOWAIT
    170170    ENDDO
    171171
    172172    if (present(pkf)) then
    173        !    calcul de pkf
     173      !    calcul de pkf
    174174
    175        DO l = 1, llm
    176           !$OMP DO SCHEDULE(STATIC)
    177           DO   ij  = ijb, ije
    178              pkf(ij,l)=pk(ij,l)
    179           ENDDO
    180           !$OMP ENDDO NOWAIT             
    181        ENDDO
     175      DO l = 1, llm
     176        !$OMP DO SCHEDULE(STATIC)
     177        DO   ij = ijb, ije
     178          pkf(ij, l) = pk(ij, l)
     179        ENDDO
     180        !$OMP ENDDO NOWAIT
     181      ENDDO
    182182
    183        !$OMP BARRIER
     183      !$OMP BARRIER
    184184
    185        jjb=jj_begin
    186        jje=jj_end
    187 #ifdef DEBUG_IO   
    188        call WriteField_u('pkf',pkf)
    189 #endif
    190        CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
    191             2, 1, .TRUE., 1 )
    192 #ifdef DEBUG_IO   
    193        call WriteField_u('pkf',pkf)
    194 #endif     
     185      jjb = jj_begin
     186      jje = jj_end
     187      IF (CPPKEY_DEBUGIO) THEN
     188        CALL WriteField_u('pkf', pkf)
     189      END IF
     190      CALL filtreg_p (pkf, jjb_u, jje_u, jjb, jje, jmp1, llm, &
     191              2, 1, .TRUE., 1)
     192      IF (CPPKEY_DEBUGIO) THEN
     193        CALL WriteField_u('pkf', pkf)
     194      END IF
    195195    end if
    196196
Note: See TracChangeset for help on using the changeset viewer.