Ignore:
Timestamp:
Jul 24, 2024, 4:23:34 PM (2 months ago)
Author:
abarral
Message:

rename modules properly lmdz_*
move some unused files to obsolete/
(lint) uppercase fortran keywords

Location:
LMDZ6/branches/Amaury_dev/libf/dyn3dmem
Files:
69 edited

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/abort_gcm.f90

    r5116 r5117  
    1818  !     ierr    = severity of situation ( = 0 normal )
    1919
    20   CHARACTER(LEN=*), intent(in):: modname
     20  CHARACTER(LEN=*), INTENT(IN):: modname
    2121  INTEGER :: ierr, ierror_mpi
    22   CHARACTER(LEN=*), intent(in):: message
     22  CHARACTER(LEN=*), INTENT(IN):: message
    2323
    2424  WRITE(lunout,*) 'in abort_gcm'
    … …  
    2626  CALL histclo
    2727  CALL restclo
    28   if (MPI_rank == 0) THEN
     28  IF (MPI_rank == 0) THEN
    2929     CALL getin_dump
    30   endif
     30  ENDIF
    3131!$OMP END MASTER
    3232  ! CALL histclo(2)
    … …  
    3636  WRITE(lunout,*) 'Stopping in ', modname
    3737  WRITE(lunout,*) 'Reason = ',message
    38   if (ierr == 0) THEN
     38  IF (ierr == 0) THEN
    3939    WRITE(lunout,*) 'Everything is cool'
    4040  else
    4141    WRITE(lunout,*) 'Houston, we have a problem, ierr = ', ierr
    4242
    43     if (using_mpi) THEN
     43    IF (using_mpi) THEN
    4444!$OMP CRITICAL (MPI_ABORT_GCM)
    4545      CALL MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
    … …  
    4949    endif
    5050
    51   endif
     51  ENDIF
    5252END SUBROUTINE abort_gcm

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/addfi_loc.f90

    r5116 r5117  
    9696!$OMP END DO NOWAIT
    9797
    98   if (pole_nord) THEN
     98  IF (pole_nord) THEN
    9999!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    100100    DO  k    = 1, llm
    … …  
    109109   ENDDO
    110110!$OMP END DO NOWAIT
    111   endif
    112 
    113   if (pole_sud) THEN
     111  ENDIF
     112
     113  IF (pole_sud) THEN
    114114!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    115115    DO  k    = 1, llm
    … …  
    124124   ENDDO
    125125!$OMP END DO NOWAIT
    126   endif
     126  ENDIF
    127127  !
    128128
    129129  ijb=ij_begin
    130130  ije=ij_end
    131   if (pole_nord) ijb=ij_begin+iip1
    132   if (pole_sud)  ije=ij_end-iip1
     131  IF (pole_nord) ijb=ij_begin+iip1
     132  IF (pole_sud)  ije=ij_end-iip1
    133133
    134134!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    140140!$OMP END DO NOWAIT
    141141
    142   if (pole_nord) ijb=ij_begin
     142  IF (pole_nord) ijb=ij_begin
    143143
    144144!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    151151
    152152  !
    153   if (pole_sud)  ije=ij_end
     153  IF (pole_sud)  ije=ij_end
    154154!$OMP MASTER
    155155  DO j = ijb,ije
    … …  
    158158!$OMP END MASTER
    159159
    160   if (planet_type=="earth") THEN
     160  IF (planet_type=="earth") THEN
    161161  ! earth case, special treatment for first 2 tracers (water)
    162162  DO iq = 1, 2
    … …  
    193193!$OMP END DO NOWAIT
    194194   ENDDO
    195   endif ! of if (planet_type=="earth")
     195  ENDIF ! of if (planet_type=="earth")
    196196
    197197!$OMP MASTER
    198   if (pole_nord) THEN
     198  IF (pole_nord) THEN
    199199    DO  ij   = 1, iim
    200200      xpn(ij) = aire(   ij   ) * pps(  ij     )
    … …  
    207207    ENDDO
    208208
    209   endif
    210 
    211   if (pole_sud) THEN
     209  ENDIF
     210
     211  IF (pole_sud) THEN
    212212    DO  ij   = 1, iim
    213213      xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
    … …  
    220220    ENDDO
    221221
    222   endif
     222  ENDIF
    223223!$OMP END MASTER
    224224
    225   if (pole_nord) THEN
     225  IF (pole_nord) THEN
    226226    DO iq = 1, nqtot
    227227!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    238238!$OMP END DO NOWAIT     
    239239    ENDDO
    240   endif
    241 
    242   if (pole_sud) THEN
     240  ENDIF
     241
     242  IF (pole_sud) THEN
    243243    DO iq = 1, nqtot
    244244!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    255255!$OMP END DO NOWAIT     
    256256    ENDDO
    257   endif
     257  ENDIF
    258258
    259259

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/advect_new_loc.f90

    r5116 r5117  
    7575  ijb = ij_begin
    7676  ije = ij_end
    77   if (pole_nord) ijb = ijb + iip1
    78   if (pole_sud)  ije = ije - iip1
     77  IF (pole_nord) ijb = ijb + iip1
     78  IF (pole_sud)  ije = ije - iip1
    7979
    8080  DO ij = ijb, ije
    … …  
    8585  ijb = ij_begin
    8686  ije = ij_end
    87   if (pole_sud)  ije = ij_end - iip1
     87  IF (pole_sud)  ije = ij_end - iip1
    8888
    8989  DO ij = ijb, ije
    … …  
    107107    ijb = ij_begin
    108108    ije = ij_end
    109     if (pole_nord) ijb = ijb + iip1
    110     if (pole_sud)  ije = ije - iip1
     109    IF (pole_nord) ijb = ijb + iip1
     110    IF (pole_sud)  ije = ije - iip1
    111111
    112112    ! DO    ij     = iip2, ip1jmp1
    … …  
    124124    ENDDO
    125125
    126     if (pole_nord) THEN
     126    IF (pole_nord) THEN
    127127      DO      ij = 1, iip1
    128128        uav(ij, l) = 0.
    … …  
    130130    endif
    131131
    132     if (pole_sud) THEN
     132    IF (pole_sud) THEN
    133133      DO      ij = 1, iip1
    134134        uav(ip1jm + ij, l) = 0.
    … …  
    145145  ijb = ij_begin
    146146  ije = ij_end
    147   if (pole_sud)  ije = ij_end - iip1
     147  IF (pole_sud)  ije = ij_end - iip1
    148148
    149149  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    180180    ijb = ij_begin
    181181    ije = ij_end + iip1
    182     if (pole_sud)  ije = ij_end
     182    IF (pole_sud)  ije = ij_end
    183183
    184184    DO ij = ijb, ije
    … …  
    191191    ijb = ij_begin
    192192    ije = ij_end
    193     if (pole_nord) ijb = ijb + iip1
    194     if (pole_sud)  ije = ije - iip1
     193    IF (pole_nord) ijb = ijb + iip1
     194    IF (pole_sud)  ije = ije - iip1
    195195
    196196    DO ij = ijb, ije - 1
    … …  
    204204    ijb = ij_begin
    205205    ije = ij_end
    206     if (pole_sud)  ije = ij_end - iip1
     206    IF (pole_sud)  ije = ij_end - iip1
    207207
    208208    DO ij = ijb, ije
    … …  
    247247  ijb = ij_begin
    248248  ije = ij_end
    249   if (pole_nord) ijb = ijb + iip1
    250   if (pole_sud)  ije = ije - iip1
     249  IF (pole_nord) ijb = ijb + iip1
     250  IF (pole_sud)  ije = ije - iip1
    251251  IF (CPPKEY_DEBUGIO) THEN
    252252    CALL WriteField_u('du_bis', du)
    … …  
    270270  ijb = ij_begin
    271271  ije = ij_end
    272   if (pole_sud)  ije = ij_end - iip1
     272  IF (pole_sud)  ije = ij_end - iip1
    273273
    274274  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/advtrac_loc.f90

    r5116 r5117  
    1414  USE Bands
    1515  USE mod_hallo
    16   USE Vampir
     16  USE lmdz_vampir
    1717  USE times
    1818  USE advtrac_mod, ONLY: finmasse
    1919  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
    20   USE strings_mod, ONLY: int2str
     20  USE lmdz_strings, ONLY: int2str
    2121  USE lmdz_description, ONLY: descript
    2222  USE lmdz_libmath, ONLY: minmax

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

    r5116 r5117  
    44  module Bands
    55  USE parallel_lmdz
    6     integer, parameter :: bands_caldyn=1
    7     integer, parameter :: bands_vanleer=2
    8     integer, parameter :: bands_dissip=3
     6    INTEGER, parameter :: bands_caldyn=1
     7    INTEGER, parameter :: bands_vanleer=2
     8    INTEGER, parameter :: bands_dissip=3
    99   
    10     INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn
    11     INTEGER,dimension(:),allocatable :: jj_Nb_vanleer
    12     INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2
    13     INTEGER,dimension(:),allocatable :: jj_Nb_dissip
    14     INTEGER,dimension(:),allocatable :: jj_Nb_physic
    15     INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis
     10    INTEGER,DIMENSION(:),ALLOCATABLE :: jj_Nb_Caldyn
     11    INTEGER,DIMENSION(:),ALLOCATABLE :: jj_Nb_vanleer
     12    INTEGER,DIMENSION(:),ALLOCATABLE :: jj_Nb_vanleer2
     13    INTEGER,DIMENSION(:),ALLOCATABLE :: jj_Nb_dissip
     14    INTEGER,DIMENSION(:),ALLOCATABLE :: jj_Nb_physic
     15    INTEGER,DIMENSION(:),ALLOCATABLE :: jj_Nb_physic_bis
    1616   
    1717    TYPE(distrib),SAVE,TARGET :: distrib_Caldyn
    … …  
    2222    TYPE(distrib),SAVE,TARGET :: distrib_physic_bis
    2323
    24     INTEGER,dimension(:),allocatable :: distrib_phys
     24    INTEGER,DIMENSION(:),ALLOCATABLE :: distrib_phys
    2525 
    2626  contains
    … …  
    4646    include "dimensions.h"
    4747      INTEGER :: i,j
    48       character (len=4) :: siim,sjjm,sllm,sproc
    49       character (len=255) :: filename
     48      CHARACTER (LEN=4) :: siim,sjjm,sllm,sproc
     49      CHARACTER (LEN=255) :: filename
    5050      INTEGER :: unit_number=10
    5151      INTEGER :: ierr
    … …  
    6161      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr)
    6262     
    63       if (ierr==0) THEN
     63      IF (ierr==0) THEN
    6464         do i=0,mpi_size-1
    6565          read (unit_number,*) j,jj_nb_caldyn(i)
    … …  
    8383        do i=0,mpi_size-1
    8484          jj_nb_caldyn(i)=(jjm+1)/mpi_size
    85           if (i<MOD(jjm+1,mpi_size)) jj_nb_caldyn(i)=jj_nb_caldyn(i)+1
     85          IF (i<MOD(jjm+1,mpi_size)) jj_nb_caldyn(i)=jj_nb_caldyn(i)+1
    8686        enddo
    8787     
    … …  
    112112      do i=0,mpi_size-1
    113113         jj_nb_vanleer2(i)=(jjm+1)/mpi_size
    114          if (i<MOD(jjm+1,mpi_size)) jj_nb_vanleer2(i)=jj_nb_vanleer2(i)+1
     114         IF (i<MOD(jjm+1,mpi_size)) jj_nb_vanleer2(i)=jj_nb_vanleer2(i)+1
    115115      enddo
    116116         
    … …  
    128128       do i=0,MPI_Size-1
    129129        jj_Nb_physic(i)=jj_para_end(i)-jj_para_begin(i)+1
    130         if (i/=0) THEN
    131           if (jj_para_begin(i)==jj_para_end(i-1)) THEN
     130        IF (i/=0) THEN
     131          IF (jj_para_begin(i)==jj_para_end(i-1)) THEN
    132132            jj_Nb_physic(i-1)=jj_Nb_physic(i-1)-1
    133133          endif
    … …  
    137137      do i=0,MPI_Size-1
    138138        jj_Nb_physic_bis(i)=jj_para_end(i)-jj_para_begin(i)+1
    139         if (i/=0) THEN
    140           if (jj_para_begin(i)==jj_para_end(i-1)) THEN
     139        IF (i/=0) THEN
     140          IF (jj_para_begin(i)==jj_para_end(i-1)) THEN
    141141            jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
    142142          else
    143143            jj_Nb_physic_bis(i-1)=jj_Nb_physic_bis(i-1)+1
    144144            jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
    145           endif
     145          ENDIF
    146146        endif
    147147      enddo
    … …  
    174174
    175175    SUBROUTINE AdjustBands_caldyn(new_dist)
    176       use times
     176      USE times
    177177      USE parallel_lmdz
    178178      IMPLICIT NONE
    … …  
    182182      INTEGER :: min_proc,max_proc
    183183      INTEGER :: i,j
    184       real,allocatable,dimension(:) :: value
    185       integer,allocatable,dimension(:) :: index
     184      REAL,ALLOCATABLE,DIMENSION(:) :: value
     185      INTEGER,ALLOCATABLE,DIMENSION(:) :: index
    186186      REAL :: tmpvalue
    187187      INTEGER :: tmpindex
    … …  
    200200      do i=0,mpi_size-2
    201201        do j=i+1,mpi_size-1
    202           if (value(i)>value(j)) THEN
     202          IF (value(i)>value(j)) THEN
    203203            tmpvalue=value(i)
    204204            value(i)=value(j)
    … …  
    218218        minvalue=value(i)
    219219        min_proc=index(i)
    220         if (jj_nb_caldyn(max_proc)>2) THEN
    221           if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) THEN
     220        IF (jj_nb_caldyn(max_proc)>2) THEN
     221          IF (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) THEN
    222222             jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
    223223             jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
    224224             exit
    225225           else
    226              if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)                 &
     226             IF (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)                 &
    227227                -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) THEN
    228228               jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
    … …  
    241241   
    242242    SUBROUTINE AdjustBands_vanleer(new_dist)
    243       use times
     243      USE times
    244244      USE parallel_lmdz
    245245      IMPLICIT NONE
    … …  
    249249      INTEGER :: min_proc,max_proc
    250250      INTEGER :: i,j
    251       real,allocatable,dimension(:) :: value
    252       integer,allocatable,dimension(:) :: index
     251      REAL,ALLOCATABLE,DIMENSION(:) :: value
     252      INTEGER,ALLOCATABLE,DIMENSION(:) :: index
    253253      REAL :: tmpvalue
    254254      INTEGER :: tmpindex
    … …  
    267267      do i=0,mpi_size-2
    268268        do j=i+1,mpi_size-1
    269           if (value(i)>value(j)) THEN
     269          IF (value(i)>value(j)) THEN
    270270            tmpvalue=value(i)
    271271            value(i)=value(j)
    … …  
    286286        min_proc=index(i)
    287287
    288         if (jj_nb_vanleer(max_proc)>2) THEN
    289           if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. &
     288        IF (jj_nb_vanleer(max_proc)>2) THEN
     289          IF (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .OR. &
    290290             timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) THEN
    291291             jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
    … …  
    293293             exit
    294294           else
    295              if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) THEN
     295             IF (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) THEN
    296296               jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
    297297               jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
    … …  
    310310
    311311    SUBROUTINE AdjustBands_dissip(new_dist)
    312       use times
     312      USE times
    313313      USE parallel_lmdz
    314314      IMPLICIT NONE
    … …  
    318318      INTEGER :: min_proc,max_proc
    319319      INTEGER :: i,j
    320       real,allocatable,dimension(:) :: value
    321       integer,allocatable,dimension(:) :: index
     320      REAL,ALLOCATABLE,DIMENSION(:) :: value
     321      INTEGER,ALLOCATABLE,DIMENSION(:) :: index
    322322      REAL :: tmpvalue
    323323      INTEGER :: tmpindex
    … …  
    336336      do i=0,mpi_size-2
    337337        do j=i+1,mpi_size-1
    338           if (value(i)>value(j)) THEN
     338          IF (value(i)>value(j)) THEN
    339339            tmpvalue=value(i)
    340340            value(i)=value(j)
    … …  
    355355        min_proc=index(i)
    356356
    357         if (jj_nb_dissip(max_proc)>3) THEN
    358           if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) THEN
     357        IF (jj_nb_dissip(max_proc)>3) THEN
     358          IF (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) THEN
    359359             jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
    360360             jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
    361361             exit
    362362           else
    363              if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)         &
     363             IF (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)         &
    364364                - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) THEN
    365365               jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
    … …  
    379379
    380380    SUBROUTINE AdjustBands_physic
    381       use times
     381      USE times
    382382
    383383      ! Ehouarn: what follows is only related to // physics
    … …  
    389389
    390390      INTEGER :: i,Index
    391       real,allocatable,dimension(:) :: value
    392       integer,allocatable,dimension(:) :: Inc
     391      REAL,ALLOCATABLE,DIMENSION(:) :: value
     392      INTEGER,ALLOCATABLE,DIMENSION(:) :: Inc
    393393      REAL :: medium
    394394      INTEGER :: NbTot,sgn
    … …  
    414414      enddo
    415415     
    416       if (NbTot>=0) THEN
     416      IF (NbTot>=0) THEN
    417417        Sgn=1
    418418      else
    … …  
    425425        Inc(Index)=Inc(Index)-Sgn
    426426        Index=Index+1
    427         if (Index>mpi_size-1) Index=0
     427        IF (Index>mpi_size-1) Index=0
    428428      enddo
    429429     
    … …  
    441441
    442442      INTEGER :: i,j
    443       character (len=4) :: siim,sjjm,sllm,sproc
    444       character (len=255) :: filename
     443      CHARACTER (LEN=4) :: siim,sjjm,sllm,sproc
     444      CHARACTER (LEN=255) :: filename
    445445      INTEGER :: unit_number=10
    446446      INTEGER :: ierr
    … …  
    456456      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr)
    457457     
    458       if (ierr==0) THEN
     458      IF (ierr==0) THEN
    459459!       write (unit_number,*) '*** Bandes caldyn ***'
    460460        do i=0,mpi_size-1

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bernoui_loc.f90

    r5106 r5117  
    4545  ijb=ij_begin
    4646  ije=ij_end+iip1
    47   if (pole_sud) ije=ij_end
     47  IF (pole_sud) ije=ij_end
    4848
    4949  jjb=jj_begin
    5050  jje=jj_end+1
    51   if (pole_sud) jje=jj_end
     51  IF (pole_sud) jje=jj_end
    5252
    5353!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bilan_dyn_loc.f90

    r5116 r5117  
    1313  USE parallel_lmdz
    1414  USE mod_hallo
    15   use misc_mod
     15  USE misc_mod
    1616  USE write_field_loc
    1717  USE comconst_mod, ONLY: cpp, pi
    … …  
    5656  !   =======
    5757
    58   integer,SAVE :: icum,ncum
     58  INTEGER,SAVE :: icum,ncum
    5959!$OMP THREADPRIVATE(icum,ncum)
    6060  LOGICAL,SAVE :: first=.TRUE.
    … …  
    7676  parameter (ifile=4)
    7777
    78   integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
     78  INTEGER,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
    7979  INTEGER,PARAMETER :: iovap=6,iun=7
    80   integer,PARAMETER :: i_sortie=1
    81 
    82   real,SAVE :: time=0.
    83   integer,SAVE :: itau=0.
     80  INTEGER,PARAMETER :: i_sortie=1
     81
     82  REAL,SAVE :: time=0.
     83  INTEGER,SAVE :: itau=0.
    8484!$OMP THREADPRIVATE(time,itau)
    8585
    … …  
    9595
    9696  !   champ contenant les scalaires advectés.
    97   real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
     97  REAL,SAVE,ALLOCATABLE :: Q(:,:,:,:)
    9898
    9999  !   champs cumulés
    100   real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
    101   real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
    102   real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
    103   real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
    104   real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
    105   real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
    106   real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
    107   real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
    108   real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
     100  REAL,SAVE,ALLOCATABLE ::  ps_cum(:,:)
     101  REAL,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
     102  REAL,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
     103  REAL,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
     104  REAL,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
     105  REAL,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
     106  REAL,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
     107  REAL,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
     108  REAL,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
    109109
    110110
    … …  
    125125  data ctrs/'  ','TOT','MMC','TRS','STN'/
    126126
    127   real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
    128   real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
    129   real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
    130 
    131   real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
     127  REAL,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
     128  REAL,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
     129  REAL,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
     130
     131  REAL,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
    132132
    133133  INTEGER :: i,j,l,iQ
    … …  
    139139  CHARACTER(LEN=10) :: infile
    140140
    141   integer, save :: fileid
     141  INTEGER, save :: fileid
    142142  INTEGER :: thoriid, zvertiid
    143143
    … …  
    153153  INTEGER :: zan, dayref
    154154  !
    155   real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
     155  REAL,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
    156156  INTEGER :: jjb,jje,jjn,ijb,ije
    157157  type(Request),SAVE :: Req
    … …  
    173173  !   Initialisation
    174174  !=====================================================================
    175   if (adjust) return
     175  IF (adjust) return
    176176
    177177  time=time+dt_app
    178178  itau=itau+1
    179179
    180   if (first) THEN
     180  IF (first) THEN
    181181!$OMP BARRIER
    182182!$OMP MASTER
    … …  
    223223  !   ncum est la frequence de stokage en pas de temps
    224224    ncum=dt_cum/dt_app
    225     if (abs(ncum*dt_app-dt_cum)>1.e-5*dt_app) THEN
     225    IF (abs(ncum*dt_app-dt_cum)>1.e-5*dt_app) THEN
    226226       WRITE(lunout,*) &
    227227             'Pb : le pas de cumule doit etre multiple du pas'
    … …  
    358358
    359359!$OMP END MASTER
    360   endif
     360  ENDIF
    361361
    362362
    … …  
    419419      Q_cum(:,jjb:jje,l,:)=0.
    420420      flux_uQ_cum(:,jjb:jje,l,:)=0.
    421       if (pole_sud) jje=jj_end-1
     421      IF (pole_sud) jje=jj_end-1
    422422      flux_v_cum(:,jjb:jje,l)=0.
    423423      flux_vQ_cum(:,jjb:jje,l,:)=0.
    424424    ENDDO
    425425!$OMP END DO NOWAIT
    426   endif
     426  ENDIF
    427427
    428428  IF (prt_level > 5) &
    … …  
    447447!$OMP END DO NOWAIT
    448448
    449   if (pole_sud) jje=jj_end-1
     449  IF (pole_sud) jje=jj_end-1
    450450
    451451!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    499499  jjb=jj_begin
    500500  jje=jj_end
    501   if (pole_sud) jje=jj_end-1
     501  IF (pole_sud) jje=jj_end-1
    502502
    503503  do iQ=1,nQ
    … …  
    582582  !   PAS DE TEMPS D'ECRITURE
    583583  !=====================================================================
    584   if (icum==ncum) THEN
     584  IF (icum==ncum) THEN
    585585  !=====================================================================
    586586
    … …  
    647647  jjb=jj_begin
    648648  jje=jj_end
    649   if (pole_sud) jje=jj_end-1
     649  IF (pole_sud) jje=jj_end-1
    650650
    651651!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    670670  jjb=jj_begin
    671671  jje=jj_end
    672   if (pole_sud) jje=jj_end-1
     672  IF (pole_sud) jje=jj_end-1
    673673
    674674!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    717717  jjb=jj_begin
    718718  jje=jj_end
    719   if (pole_sud) jje=jj_end-1
     719  IF (pole_sud) jje=jj_end-1
    720720
    721721  zvQ=0.
    … …  
    776776  !   sorties proprement dites
    777777!$OMP MASTER
    778   if (i_sortie==1) THEN
     778  IF (i_sortie==1) THEN
    779779  jjb=jj_begin
    780780  jje=jj_end
    781781  jjn=jj_nb
    782   if (pole_sud) jje=jj_end-1
    783   if (pole_sud) jjn=jj_nb-1
     782  IF (pole_sud) jje=jj_end-1
     783  IF (pole_sud) jjn=jj_nb-1
    784784  do iQ=1,nQ
    785785     do itr=1,ntr
    … …  
    801801        jjn*llm,ndex3d)
    802802
    803   endif
     803  ENDIF
    804804
    805805
    … …  
    832832  !/////////////////////////////////////////////////////////////////////
    833833  icum=0                  !///////////////////////////////////////
    834   endif ! icum.eq.ncum    !///////////////////////////////////////
     834  ENDIF ! icum.EQ.ncum    !///////////////////////////////////////
    835835  !/////////////////////////////////////////////////////////////////////
    836836  !=====================================================================

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/caladvtrac_loc.f90

    r5116 r5117  
    1313  USE bands
    1414  USE times
    15   USE Vampir
     15  USE lmdz_vampir
    1616  USE write_field_loc
    1717  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
    … …  
    6060  ijbv = ij_begin - iip1
    6161  ijev = ij_end
    62   if (pole_nord) ijbv = ij_begin
    63   if (pole_sud)  ijev = ij_end - iip1
     62  IF (pole_nord) ijbv = ij_begin
     63  IF (pole_sud)  ijev = ij_end - iip1
    6464
    6565  IF(iadvtr==0) THEN

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/caldyn_loc.f90

    r5113 r5117  
    144144  ije = ij_end + iip1
    145145
    146   if (pole_nord) ijb = ij_begin
    147   if (pole_sud) ije = ij_end
     146  IF (pole_nord) ijb = ij_begin
     147  IF (pole_sud) ije = ij_end
    148148
    149149  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    162162  ijb = ij_begin
    163163  ije = ij_end
    164   if (pole_sud) ije = ij_end - iip1
     164  IF (pole_sud) ije = ij_end - iip1
    165165
    166166  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/call_dissip_mod.f90

    r5116 r5117  
    8282    USE mod_hallo
    8383    USE Bands
    84     USE vampir
     84    USE lmdz_vampir
    8585    USE write_field_loc
    8686    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
    … …  
    240240      !$OMP END DO NOWAIT
    241241
    242       if (1 == 0) THEN
     242      IF (1 == 0) THEN
    243243        !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
    244244        !!!                     2) should probably not be here anyway
    … …  
    274274      !$OMP END DO NOWAIT
    275275
    276       if (1 == 0) THEN
     276      IF (1 == 0) THEN
    277277        !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
    278278        !!!                     2) should probably not be here anyway

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

    r5116 r5117  
    11SUBROUTINE check_isotopes(q, ijb, ije, err_msg)
    22   USE parallel_lmdz
    3    USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str
     3   USE lmdz_strings, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str
    44   USE infotrac,    ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, &
    55                          ntiso, iH2O, nzone, tracers, isoName,  itZonIso, getKey
    … …  
    3838      iso_O17 = strIdx(isoName,'H217O')
    3939      iso_HTO = strIdx(isoName,'HTO')
    40       if (tnat1) THEN
     40      IF (tnat1) THEN
    4141              tnat(:)=1.0
    4242      else

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

    r5116 r5117  
    9191  lunout=6
    9292  CALL getin('lunout', lunout)
    93   IF (lunout /= 5 .and. lunout /= 6) THEN
     93  IF (lunout /= 5 .AND. lunout /= 6) THEN
    9494     OPEN(UNIT=lunout,FILE='lmdz.out_0000',ACTION='write',  &
    9595          STATUS='unknown',FORM='formatted')
    … …  
    102102  ! adjust=y not implemented in case of OpenMP threads...
    103103  !$OMP PARALLEL
    104   IF ((OMP_GET_NUM_THREADS()>1).and.adjust) THEN
     104  IF ((OMP_GET_NUM_THREADS()>1).AND.adjust) THEN
    105105     WRITE(lunout,*)'conf_gcm: Error, adjust should be set to n' &
    106106          ,' when running with OpenMP threads'
    … …  
    340340  maxlatfilter = -1.0
    341341  CALL getin('maxlatfilter',maxlatfilter)
    342   if (maxlatfilter > 90) &
     342  IF (maxlatfilter > 90) &
    343343       CALL abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
    344344 
    … …  
    359359  iflag_top_bound=1
    360360  CALL getin('iflag_top_bound',iflag_top_bound)
    361   IF (iflag_top_bound < 0 .or. iflag_top_bound > 2) &
     361  IF (iflag_top_bound < 0 .OR. iflag_top_bound > 2) &
    362362       CALL abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
    363363
    … …  
    396396  CALL getin('ok_guide',ok_guide)
    397397
    398   IF (ok_guide .and. adjust) CALL abort_gcm("conf_gcm", &
     398  IF (ok_guide .AND. adjust) CALL abort_gcm("conf_gcm", &
    399399       "adjust does not work with ok_guide", 1)
    400400
    … …  
    436436  !     .........   (  modif  le 17/04/96 )   .........
    437437
    438   test_etatinit: IF (.not. etatinit) THEN
     438  test_etatinit: IF (.NOT. etatinit) THEN
    439439     !Config  Key  = clon
    440440     !Config  Desc = centre du zoom, longitude
    … …  
    933933     CALL getin('ok_strato',ok_strato)
    934934
    935      vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
     935     vert_prof_dissip = merge(1, 0, ok_strato .AND. llm==39)
    936936     CALL getin('vert_prof_dissip', vert_prof_dissip)
    937      CALL assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1, &
     937     CALL assert(vert_prof_dissip == 0 .OR. vert_prof_dissip ==  1, &
    938938          "bad value for vert_prof_dissip")
    939939

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covcont_loc.f90

    r5116 r5117  
    3333  ijev=ij_end+iip1
    3434
    35   if (pole_nord) THEN
     35  IF (pole_nord) THEN
    3636    ijbu=ij_begin+iip1
    3737    ijbv=ij_begin
    38   endif
     38  ENDIF
    3939
    40   if (pole_sud) THEN
     40  IF (pole_sud) THEN
    4141    ijeu=ij_end-iip1
    4242    ijev=ij_end-iip1
    43   endif
     43  ENDIF
    4444
    4545!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covnat_loc.f90

    r5116 r5117  
    3434  ije=ij_end
    3535
    36   if (pole_nord) THEN
     36  IF (pole_nord) THEN
    3737!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    3838    DO l = 1,klevel
    … …  
    4242    ENDDO
    4343!$OMP ENDDO NOWAIT
    44   endif
     44  ENDIF
    4545
    46   if (pole_sud) THEN
     46  IF (pole_sud) THEN
    4747!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    4848    DO l = 1,klevel
    … …  
    5252    ENDDO
    5353!$OMP ENDDO NOWAIT
    54   endif
     54  ENDIF
    5555
    5656  ijb=ij_begin
    5757  ije=ij_end
    58   if (pole_nord) ijb=ij_begin+iip1
    59   if (pole_sud)  ije=ij_end-iip1
     58  IF (pole_nord) ijb=ij_begin+iip1
     59  IF (pole_sud)  ije=ij_end-iip1
    6060
    6161!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    6969  ijb=ij_begin-iip1
    7070  ije=ij_end
    71   if (pole_nord) ijb=ij_begin
    72   if (pole_sud)  ije=ij_end-iip1
     71  IF (pole_nord) ijb=ij_begin
     72  IF (pole_sud)  ije=ij_end-iip1
    7373
    7474!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dissip_loc.f90

    r5116 r5117  
    9292  !$OMP END DO NOWAIT
    9393
    94   if (pole_sud) ije = ij_end - iip1
     94  IF (pole_sud) ije = ij_end - iip1
    9595
    9696  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    121121  ijb = ij_begin
    122122  ije = ij_end
    123   if (pole_sud) ije = ij_end - iip1
    124 
    125   !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    126   DO l = 1, llm
    127     if (pole_nord) THEN
     123  IF (pole_sud) ije = ij_end - iip1
     124
     125  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     126  DO l = 1, llm
     127    IF (pole_nord) THEN
    128128      DO ij = 1, iip1
    129129        gdx(ij, l) = 0.
    … …  
    131131    endif
    132132
    133     if (pole_sud) THEN
     133    IF (pole_sud) THEN
    134134      DO ij = 1, iip1
    135135        gdx(ij + ip1jm, l) = 0.
    … …  
    137137    endif
    138138
    139     if (pole_nord) ijb = ij_begin + iip1
     139    IF (pole_nord) ijb = ij_begin + iip1
    140140    DO ij = ijb, ije
    141141      du(ij, l) = du(ij, l) - te1dt(l) * gdx(ij, l)
    142142    ENDDO
    143143
    144     if (pole_nord) ijb = ij_begin
     144    IF (pole_nord) ijb = ij_begin
    145145    DO ij = ijb, ije
    146146      dv(ij, l) = dv(ij, l) - te1dt(l) * gdy(ij, l)
    … …  
    166166  ijb = ij_begin
    167167  ije = ij_end
    168   if (pole_sud) ije = ij_end - iip1
    169 
    170   !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    171   DO l = 1, llm
    172 
    173     if (pole_nord) THEN
     168  IF (pole_sud) ije = ij_end - iip1
     169
     170  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     171  DO l = 1, llm
     172
     173    IF (pole_nord) THEN
    174174      DO ij = 1, iip1
    175175        grx(ij, l) = 0.
    … …  
    177177    endif
    178178
    179     if (pole_nord) ijb = ij_begin + iip1
     179    IF (pole_nord) ijb = ij_begin + iip1
    180180    DO ij = ijb, ije
    181181      du(ij, l) = du(ij, l) - te2dt(l) * grx(ij, l)
    182182    ENDDO
    183183
    184     if (pole_nord) ijb = ij_begin
     184    IF (pole_nord) ijb = ij_begin
    185185    DO ij = ijb, ije
    186186      dv(ij, l) = dv(ij, l) - te2dt(l) * gry(ij, l)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_gam_loc.f90

    r5116 r5117  
    4747  ijb=ij_begin
    4848  ije=ij_end
    49   if (pole_nord) ijb=ij_begin+iip1
     49  IF (pole_nord) ijb=ij_begin+iip1
    5050  IF(pole_sud)  ije=ij_end-iip1
    5151
    … …  
    7070  ! ....  calcul  aux poles  .....
    7171  !
    72    if (pole_nord) THEN
     72   IF (pole_nord) THEN
    7373      DO  ij  = 1,iim
    7474       aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
    … …  
    8181   endif
    8282
    83     if (pole_sud) THEN
     83    IF (pole_sud) THEN
    8484      DO  ij  = 1,iim
    8585       aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/diverg_p.f90

    r5116 r5117  
    4343  ijb=ij_begin
    4444  ije=ij_end
    45   if (pole_nord) ijb=ij_begin+iip1
     45  IF (pole_nord) ijb=ij_begin+iip1
    4646  IF(pole_sud)  ije=ij_end-iip1
    4747
    … …  
    6565  ! ....  calcul  aux poles  .....
    6666  !
    67     if (pole_nord) THEN
     67    IF (pole_nord) THEN
    6868      DO  ij  = 1,iim
    6969       aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
    … …  
    7676    endif
    7777
    78    if (pole_sud) THEN
     78   IF (pole_sud) THEN
    7979      DO  ij  = 1,iim
    8080       aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divergf_loc.f90

    r5116 r5117  
    4545  ijb=ij_begin
    4646  ije=ij_end
    47   if (pole_nord) ijb=ij_begin+iip1
     47  IF (pole_nord) ijb=ij_begin+iip1
    4848  IF(pole_sud)  ije=ij_end-iip1
    4949
    … …  
    6868  ! ....  calcul  aux poles  .....
    6969  !
    70     if (pole_nord) THEN
     70    IF (pole_nord) THEN
    7171      DO  ij  = 1,iim
    7272       aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
    … …  
    8181    endif
    8282
    83     if (pole_sud) THEN
     83    IF (pole_sud) THEN
    8484      DO  ij  = 1,iim
    8585       aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
    … …  
    9999    jjb=jj_begin
    100100    jje=jj_end
    101     if (pole_sud) jje=jj_end-1
     101    IF (pole_sud) jje=jj_end-1
    102102
    103103    CALL filtreg_p( div,jjb_u,jje_u,jjb,jje, jjp1, &

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dteta1_loc.f90

    r5116 r5117  
    4444  ije=ij_end
    4545
    46   if (pole_nord) ijb=ij_begin+iip1
    47   if (pole_sud)  ije=ij_end-iip1
     46  IF (pole_nord) ijb=ij_begin+iip1
     47  IF (pole_sud)  ije=ij_end-iip1
    4848
    4949  DO ij = ijb, ije - 1
    … …  
    6060
    6161  ijb=ij_begin-iip1
    62   if (pole_nord) ijb=ij_begin
     62  IF (pole_nord) ijb=ij_begin
    6363
    6464  DO ij = ijb,ije
    … …  
    6666  END DO
    6767
    68    if (.not. pole_sud) THEN
     68   IF (.NOT. pole_sud) THEN
    6969      hbxu(ije+1:ije+iip1,l) = 0
    7070      hbyv(ije+1:ije+iip1,l) = 0

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv1_loc.f90

    r5106 r5117  
    3333  ije=ij_end
    3434
    35   if (pole_nord) ijb=ij_begin+iip1
    36   if (pole_sud)  ije=ij_end-iip1
     35  IF (pole_nord) ijb=ij_begin+iip1
     36  IF (pole_sud)  ije=ij_end-iip1
    3737
    3838  DO ij = ijb, ije-1
    … …  
    4444
    4545  !
    46   if (pole_nord) ijb=ij_begin
     46  IF (pole_nord) ijb=ij_begin
    4747
    4848  DO ij = ijb, ije-1

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv2_loc.f90

    r5106 r5117  
    3737  ijb=ij_begin
    3838  ije=ij_end
    39   if (pole_nord) ijb=ijb+iip1
    40   if (pole_sud)  ije=ije-iip1
     39  IF (pole_nord) ijb=ijb+iip1
     40  IF (pole_sud)  ije=ije-iip1
    4141
    4242  DO ij  = ijb, ije - 1
    … …  
    5555  !
    5656  !
    57   if (pole_nord) ijb=ijb-iip1
     57  IF (pole_nord) ijb=ijb-iip1
    5858
    5959  DO ij  = ijb,ije

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

    r5116 r5117  
    88  USE parallel_lmdz
    99  USE infotrac,    ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName
    10   USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx
     10  USE lmdz_strings, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx
    1111  USE netcdf,      ONLY: nf90_open,  nf90_nowrite, nf90_inquire_dimension, nf90_inq_varid, &
    1212                         nf90_close, nf90_get_var, nf90_inquire_variable,  nf90_noerr
    13   USE readTracFiles_mod, ONLY: new2oldH2O, newHNO3, oldHNO3, getKey
     13  USE lmdz_readTracFiles, ONLY: new2oldH2O, newHNO3, oldHNO3, getKey
    1414  USE control_mod, ONLY: planet_type
    1515  USE lmdz_assert_eq, ONLY: assert_eq
    … …  
    182182      iqParent = tracers(iq)%iqParent
    183183      IF(tracers(iq)%iso_iZone == 0) THEN
    184          if (tnat1) THEN
     184         IF (tnat1) THEN
    185185                 tnat=1.0
    186186                 alpha_ideal=1.0

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

    r5114 r5117  
    77  USE parallel_lmdz
    88  USE mod_hallo
    9   USE strings_mod, ONLY: maxlen
     9  USE lmdz_strings, ONLY: maxlen
    1010  USE infotrac, ONLY: nqtot, tracers
    1111  USE netcdf, ONLY: nf90_create, nf90_def_dim, nf90_inq_varid, nf90_global,    &
    … …  
    166166  USE parallel_lmdz
    167167  USE mod_hallo
    168   USE strings_mod, ONLY: maxlen
     168  USE lmdz_strings, ONLY: maxlen
    169169  USE infotrac, ONLY: nqtot, tracers, type_trac
    170170  USE control_mod

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

    r5116 r5117  
    6363
    6464    ! Sanity check
    65     if (firstcall) THEN
     65    IF (firstcall) THEN
    6666      ! sanity checks for Shallow Water case (1 vertical layer)
    67       if (llm==1) THEN
    68         if (kappa/=1) THEN
     67      IF (llm==1) THEN
     68        IF (kappa/=1) THEN
    6969          CALL abort_gcm(modname, &
    7070                  "kappa!=1 , but running in Shallow Water mode!!", 42)
    7171        endif
    72         if (cpp/=r) THEN
     72        IF (cpp/=r) THEN
    7373          CALL abort_gcm(modname, &
    7474                  "cpp!=r , but running in Shallow Water mode!!", 42)
    7575        endif
    76       endif ! of if (llm.eq.1)
     76      endif ! of if (llm.EQ.1)
    7777
    7878      firstcall = .FALSE.
    … …  
    8282
    8383    ! Specific behaviour for Shallow Water (1 vertical layer) case:
    84     if (llm==1) THEN
     84    IF (llm==1) THEN
    8585      ! Compute pks(:),pk(:),pkf(:)
    8686      ijb = ij_begin
    … …  
    9090        pks(ij) = (cpp / preff) * ps(ij)
    9191        pk(ij, 1) = .5 * pks(ij)
    92         if (present(pkf)) pkf(ij, 1) = pk(ij, 1)
     92        IF (present(pkf)) pkf(ij, 1) = pk(ij, 1)
    9393      ENDDO
    9494      !$OMP ENDDO
    9595
    9696      !$OMP BARRIER
    97       if (present(pkf)) THEN
     97      IF (present(pkf)) THEN
    9898        jjb = jj_begin
    9999        jje = jj_end
    … …  
    104104      ! our work is done, exit routine
    105105      RETURN
    106     endif ! of if (llm.eq.1)
     106    endif ! of if (llm.EQ.1)
    107107
    108108    ! General case:
    … …  
    169169    ENDDO
    170170
    171     if (present(pkf)) THEN
     171    IF (present(pkf)) THEN
    172172      !    calcul de pkf
    173173

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

    r5116 r5117  
    5656
    5757    ! Sanity check
    58     if (firstcall) THEN
     58    IF (firstcall) THEN
    5959       ! sanity checks for Shallow Water case (1 vertical layer)
    60        if (llm==1) THEN
    61           if (kappa/=1) THEN
     60       IF (llm==1) THEN
     61          IF (kappa/=1) THEN
    6262             CALL abort_gcm(modname, &
    6363                  "kappa!=1 , but running in Shallow Water mode!!",42)
    6464          endif
    65           if (cpp/=r) THEN
     65          IF (cpp/=r) THEN
    6666             CALL abort_gcm(modname, &
    6767                  "cpp!=r , but running in Shallow Water mode!!",42)
    6868          endif
    69        endif ! of if (llm.eq.1)
     69       endif ! of if (llm.EQ.1)
    7070
    7171       firstcall=.FALSE.
    … …  
    7575
    7676    ! Specific behaviour for Shallow Water (1 vertical layer) case:
    77     if (llm==1) THEN
     77    IF (llm==1) THEN
    7878       ! Compute pks(:),pk(:),pkf(:)
    7979       ijb=ij_begin
    … …  
    8383          pks(ij) = (cpp/preff) * ps(ij)
    8484          pk(ij,1) = .5*pks(ij)
    85           if (present(pkf)) pkf(ij,1)=pk(ij,1)
     85          IF (present(pkf)) pkf(ij,1)=pk(ij,1)
    8686       ENDDO
    8787       !$OMP ENDDO
    8888
    8989       !$OMP BARRIER
    90        if (present(pkf)) THEN
     90       IF (present(pkf)) THEN
    9191          jjb=jj_begin
    9292          jje=jj_end
    … …  
    9797       ! our work is done, exit routine
    9898       RETURN
    99     endif ! of if (llm.eq.1)
     99    endif ! of if (llm.EQ.1)
    100100
    101101    ! General case:
    … …  
    140140    !$OMP ENDDO NOWAIT       
    141141
    142     if (present(pkf)) THEN
     142    IF (present(pkf)) THEN
    143143       !    calcul de pkf
    144144

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

    r5113 r5117  
    9999  !-------------------------------------------------------c
    100100
    101   IF(ifiltre==1.or.ifiltre==-1) &
     101  IF(ifiltre==1.OR.ifiltre==-1) &
    102102        CALL abort_gcm("fitreg_p","Pas de transformee simple&
    103103        &dans cette version",1)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/fluxstokenc_p.f90

    r5116 r5117  
    1010  USE bands
    1111  USE times
    12   USE Vampir
     12  USE lmdz_vampir
    1313  USE write_field_loc
    1414
    … …  
    5050  ijbv = ij_begin - iip1
    5151  ijev = ij_end
    52   if (pole_nord) ijbv = ij_begin
    53   if (pole_sud)  ijev = ij_end - iip1
     52  IF (pole_nord) ijbv = ij_begin
     53  IF (pole_sud)  ijev = ij_end - iip1
    5454
    5555  IF(pasflx==0) THEN
    … …  
    116116    !$OMP ENDDO NOWAIT
    117117
    118     if (pole_sud) ije = ij_end - iip1
     118    IF (pole_sud) ije = ij_end - iip1
    119119
    120120    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/friction_loc.f90

    r5116 r5117  
    2929
    3030  ! arguments:
    31   REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
    32   REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
    33   REAL,INTENT(in) :: pdt ! time step
     31  REAL,INTENT(INOUT) :: ucov( iip1,jjb_u:jje_u,llm )
     32  REAL,INTENT(INOUT) :: vcov( iip1,jjb_v:jje_v,llm )
     33  REAL,INTENT(IN) :: pdt ! time step
    3434
    3535  ! local variables:
    … …  
    5151    ! set friction type
    5252    CALL getin("friction_type",friction_type)
    53     if ((friction_type<0).or.(friction_type>1)) THEN
     53    IF ((friction_type<0).OR.(friction_type>1)) THEN
    5454      abort_message="wrong friction type"
    5555      WRITE(lunout,*)'Friction: wrong friction type',friction_type
    … …  
    6060!$OMP END SINGLE COPYPRIVATE(friction_type,firstcall)
    6161
    62   if (friction_type==0) then ! friction on first layer only
     62  IF (friction_type==0) then ! friction on first layer only
    6363!$OMP SINGLE
    6464  !   calcul des composantes au carre du vent naturel
    6565  jjb=jj_begin
    6666  jje=jj_end+1
    67   if (pole_sud) jje=jj_end
     67  IF (pole_sud) jje=jj_end
    6868
    6969  do j=jjb,jje
    … …  
    7575  jjb=jj_begin-1
    7676  jje=jj_end+1
    77   if (pole_nord) jjb=jj_begin
    78   if (pole_sud) jje=jj_end-1
     77  IF (pole_nord) jjb=jj_begin
     78  IF (pole_sud) jje=jj_end-1
    7979
    8080  do j=jjb,jje
    … …  
    8787  jjb=jj_begin
    8888  jje=jj_end+1
    89   if (pole_nord) jjb=jj_begin+1
    90   if (pole_sud) jje=jj_end-1
     89  IF (pole_nord) jjb=jj_begin+1
     90  IF (pole_sud) jje=jj_end-1
    9191
    9292  do j=jjb,jje
    … …  
    9999  !   les deux composantes du vent au pole sont obtenues comme
    100100  !   premiers modes de fourier de v pres du pole
    101   if (pole_nord) THEN
     101  IF (pole_nord) THEN
    102102    upoln=0.
    103103    vpoln=0.
    … …  
    116116    enddo
    117117
    118   endif
     118  ENDIF
    119119
    120   if (pole_sud) THEN
     120  IF (pole_sud) THEN
    121121    upols=0.
    122122    vpols=0.
    … …  
    134134    enddo
    135135
    136   endif
     136  ENDIF
    137137
    138138  !   calcul du frottement au sol.
    … …  
    140140  jjb=jj_begin
    141141  jje=jj_end
    142   if (pole_nord) jjb=jj_begin+1
    143   if (pole_sud) jje=jj_end-1
     142  IF (pole_nord) jjb=jj_begin+1
     143  IF (pole_sud) jje=jj_end-1
    144144
    145145  do j=jjb,jje
    … …  
    153153  jjb=jj_begin
    154154  jje=jj_end
    155   if (pole_sud) jje=jj_end-1
     155  IF (pole_sud) jje=jj_end-1
    156156
    157157  do j=jjb,jje
    … …  
    163163  enddo
    164164!$OMP END SINGLE
    165   endif ! of if (friction_type.eq.0)
     165  ENDIF ! of if (friction_type.EQ.0)
    166166
    167   if (friction_type==1) THEN
     167  IF (friction_type==1) THEN
    168168   ! for ucov()
    169169    jjb=jj_begin
    170170    jje=jj_end
    171     if (pole_nord) jjb=jj_begin+1
    172     if (pole_sud) jje=jj_end-1
     171    IF (pole_nord) jjb=jj_begin+1
     172    IF (pole_sud) jje=jj_end-1
    173173
    174174!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    182182    jjb=jj_begin
    183183    jje=jj_end
    184     if (pole_sud) jje=jj_end-1
     184    IF (pole_sud) jje=jj_end-1
    185185
    186186!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    190190    enddo
    191191!$OMP END DO
    192   endif ! of if (friction_type.eq.1)
     192  ENDIF ! of if (friction_type.EQ.1)
    193193
    194194

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

    r5116 r5117  
    8787  LOGICAL lafin
    8888
    89   real time_step, t_wrt, t_ops
     89  REAL time_step, t_wrt, t_ops
    9090
    9191  !+jld variables test conservation energie
    … …  
    101101
    102102
    103   character (len=80) :: dynhist_file, dynhistave_file
    104   character (len=20) :: modname
    105   character (len=80) :: abort_message
     103  CHARACTER (LEN=80) :: dynhist_file, dynhistave_file
     104  CHARACTER (LEN=20) :: modname
     105  CHARACTER (LEN=80) :: abort_message
    106106  ! locales pour gestion du temps
    107107  INTEGER :: an, mois, jour
    108108  REAL :: heure
    109109  ! needed for xios interface
    110   character (len=10) :: xios_cal_type
     110  CHARACTER (LEN=10) :: xios_cal_type
    111111  INTEGER :: anref, moisref, jourref
    112112  REAL :: heureref
    … …  
    132132
    133133  CALL conf_gcm( 99, .TRUE. )
    134   if (mod(iphysiq, iperiod) /= 0) CALL abort_gcm("conf_gcm", &
     134  IF (mod(iphysiq, iperiod) /= 0) CALL abort_gcm("conf_gcm", &
    135135       "iphysiq must be a multiple of iperiod", 1)
    136136
    … …  
    154154
    155155  CALL set_bands
    156   if (mpi_rank==0) CALL WriteBands
     156  IF (mpi_rank==0) CALL WriteBands
    157157  CALL Set_Distrib(distrib_caldyn)
    158158
    … …  
    173173  !      calend = 'earth_365d'
    174174
    175   if (calend == 'earth_360d') THEN
     175  IF (calend == 'earth_360d') THEN
    176176     CALL ioconf_calendar('360_day')
    177177     WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
    178178     xios_cal_type='d360'
    179   else if (calend == 'earth_365d') THEN
     179  ELSE IF (calend == 'earth_365d') THEN
    180180     CALL ioconf_calendar('noleap')
    181181     WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
    182182     xios_cal_type='noleap'
    183   else if (calend == 'gregorian') THEN
     183  ELSE IF (calend == 'gregorian') THEN
    184184     CALL ioconf_calendar('gregorian')
    185185     WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile'
    … …  
    188188     abort_message = 'Mauvais choix de calendrier'
    189189     CALL abort_gcm(modname,abort_message,1)
    190   endif
     190  ENDIF
    191191
    192192
    … …  
    212212
    213213  !  lecture du fichier start.nc
    214   if (read_start) THEN
     214  IF (read_start) THEN
    215215     ! we still need to run iniacademic to initialize some
    216216     ! constants & fields, if we run the 'newtonian' or 'SW' cases:
    217      if (iflag_phys/=1) THEN
     217     IF (iflag_phys/=1) THEN
    218218        CALL iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
    219219     endif
    220220
    221      !        if (planet_type.eq."earth") THEN
     221     !        if (planet_type.EQ."earth") THEN
    222222     ! Load an Earth-format start file
    223223     CALL dynetat0_loc("start.nc",vcov,ucov, &
    224224          teta,q,masse,ps,phis, time_0)
    225      !        endif ! of if (planet_type.eq."earth")
     225     !        endif ! of if (planet_type.EQ."earth")
    226226
    227227     !       WRITE(73,*) 'ucov',ucov
    … …  
    231231     !       WRITE(77,*) 'q',q
    232232
    233   endif ! of if (read_start)
     233  ENDIF ! of if (read_start)
    234234
    235235  ! le cas echeant, creation d un etat initial
    236236  IF (prt_level > 9) WRITE(lunout,*) &
    237237       'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT'
    238   if (.not.read_start) THEN
     238  IF (.NOT.read_start) THEN
    239239     start_time=0.
    240240     annee_ref=anneeref
    241241     CALL iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
    242   endif
     242  ENDIF
    243243
    244244  !-----------------------------------------------------------------------
    … …  
    287287     WRITE(lunout,*) &
    288288          'GCM: On reinitialise a la date lue dans gcm.def'
    289   ELSE IF (annee_ref /= anneeref .or. day_ref /= dayref) THEN
     289  ELSE IF (annee_ref /= anneeref .OR. day_ref /= dayref) THEN
    290290     WRITE(lunout,*) &
    291291          'GCM: Attention les dates initiales lues dans le fichier'
    … …  
    297297     WRITE(lunout,*)' Pas de remise a zero'
    298298  ENDIF
    299   !      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN
     299  !      if (annee_ref .NE. anneeref .OR. day_ref .NE. dayref) THEN
    300300  !        WRITE(lunout,*)
    301301  !     .  'GCM: Attention les dates initiales lues dans le fichier'
    … …  
    305305  !        WRITE(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
    306306  !        WRITE(lunout,*)' day_ref=',day_ref," dayref=",dayref
    307   !        if (raz_date .ne. 1) THEN
     307  !        if (raz_date .NE. 1) THEN
    308308  !          WRITE(lunout,*)
    309309  !     .    'GCM: On garde les dates du fichier restart'
    … …  
    337337  WRITE(lunout,*)jD_ref+jH_ref,anref, moisref, jourref, heureref
    338338
    339   if (iflag_phys==1) THEN
     339  IF (iflag_phys==1) THEN
    340340     ! these initialisations have already been done (via iniacademic)
    341341     ! if running in SW or Newtonian mode
    … …  
    355355     !   --------------------------
    356356     CALL inifilr
    357   endif ! of if (iflag_phys.eq.1)
     357  ENDIF ! of if (iflag_phys.EQ.1)
    358358
    359359  !-----------------------------------------------------------------------
    … …  
    369369
    370370
    371   if (nday>=0) THEN
     371  IF (nday>=0) THEN
    372372     day_end = day_ini + nday
    373373  else
    374374     day_end = day_ini - nday/day_step
    375   endif
     375  ENDIF
    376376
    377377  WRITE(lunout,300)day_ini,day_end
    … …  
    395395  istphy=istdyn/iphysiq
    396396
    397   IF ((iflag_phys==1).or.(iflag_phys>=100)) THEN
     397  IF ((iflag_phys==1).OR.(iflag_phys>=100)) THEN
    398398     ! Physics:
    399399    IF (CPPKEY_PHYS) THEN
    … …  
    404404            iflag_phys)
    405405    END IF
    406   ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100))
    407 
    408 
    409   !      if (planet_type.eq."earth") THEN
     406  ENDIF ! of IF ((iflag_phys==1).OR.(iflag_phys>=100))
     407
     408
     409  !      if (planet_type.EQ."earth") THEN
    410410  ! Write an Earth-format restart file
    411411  CALL dynredem0_loc("restart.nc", day_end, phis)
    … …  
    415415
    416416  time_step = zdtvr
    417      if (ok_dyn_ins) THEN
     417     IF (ok_dyn_ins) THEN
    418418        ! initialize output file for instantaneous outputs
    419419        ! t_ops = iecri * daysec ! do operations every t_ops
    … …  
    433433
    434434! setting up DYN3D/XIOS inerface
    435   if (ok_dyn_xios) THEN
     435  IF (ok_dyn_xios) THEN
    436436      CALL xios_dyn3dmem_init(xios_cal_type, anref, moisref, jourref,heureref, an,   &
    437437          mois, jour, heure, zdtvr)
    438   endif
     438  ENDIF
    439439
    440440  !-----------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gr_v_scal_loc.f90

    r5116 r5117  
    4949  ijb=ij_begin
    5050  ije=ij_end
    51   if (pole_nord) ijb=ij_begin+iip1
    52   if (pole_sud)  ije=ij_end-iip1
     51  IF (pole_nord) ijb=ij_begin+iip1
     52  IF (pole_sud)  ije=ij_end-iip1
    5353
    5454!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    6262!$OMP ENDDO NOWAIT
    6363
    64   if (pole_nord) THEN
     64  IF (pole_nord) THEN
    6565!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    6666    DO l=1,nx
    … …  
    7070    ENDDO
    7171!$OMP ENDDO NOWAIT
    72   endif
     72  ENDIF
    7373
    74   if (pole_sud) THEN
     74  IF (pole_sud) THEN
    7575!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    7676    DO l=1,nx
    … …  
    8080    ENDDO
    8181!$OMP ENDDO NOWAIT
    82   endif
     82  ENDIF
    8383
    8484

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_loc.f90

    r5105 r5117  
    4040  ijb=ij_begin-iip1
    4141  ije=ij_end
    42   if (pole_nord) ijb=ij_begin
    43   if (pole_sud)  ije=ij_end-iip1
     42  IF (pole_nord) ijb=ij_begin
     43  IF (pole_sud)  ije=ij_end-iip1
    4444
    4545  DO ij = ijb,ije

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/grad_p.f90

    r5105 r5117  
    4040  ijb=ij_begin-iip1
    4141  ije=ij_end
    42   if (pole_nord) ijb=ij_begin
    43   if (pole_sud)  ije=ij_end-iip1
     42  IF (pole_nord) ijb=ij_begin
     43  IF (pole_sud)  ije=ij_end-iip1
    4444
    4545  DO ij = ijb,ije

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gradiv2_loc.f90

    r5116 r5117  
    133133   DO   l = 1, klevel
    134134
    135      if (pole_sud) ije=ij_end
     135     IF (pole_sud) ije=ij_end
    136136     DO  ij = ijb, ije
    137137      gdx_out( ij,l ) = gdx( ij,l ) * nugrads
    138138     ENDDO
    139139
    140      if (pole_sud) ije=ij_end-iip1
     140     IF (pole_sud) ije=ij_end-iip1
    141141     DO  ij = ijb, ije
    142142      gdy_out( ij,l ) = gdy( ij,l ) * nugrads

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupe_loc.f90

    r5116 r5117  
    3535  INTEGER :: i, j, l
    3636
    37   logical :: firstcall
     37  LOGICAL :: firstcall
    3838  save firstcall
    3939  !$OMP THREADPRIVATE(firstcall)
    … …  
    6262  jjb = jj_begin - 1
    6363  jje = jj_end
    64   if (pole_nord) jjb = jj_begin
    65   if (pole_sud)  jje = jj_end - 1
     64  IF (pole_nord) jjb = jj_begin
     65  IF (pole_sud)  jje = jj_end - 1
    6666  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    6767  do l = 1, llm
    … …  
    8181  jjb = jj_begin
    8282  jje = jj_end
    83   if (pole_nord) jjb = jj_begin + 1
    84   if (pole_sud)  jje = jj_end - 1
     83  IF (pole_nord) jjb = jj_begin + 1
     84  IF (pole_sud)  jje = jj_end - 1
    8585
    8686  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    113113  enddo
    114114
    115   if (.not. pole_sud) THEN
     115  IF (.NOT. pole_sud) THEN
    116116    zconvmm(:, jj_end + 1, :) = 0
    117117    !ym wm(:,jj_end+1,:)=0
    118   endif
     118  ENDIF
    119119
    120120  !$OMP END MASTER

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

    r5116 r5117  
    11MODULE guide_loc_mod
    22
    3 !=======================================================================
    4 !   Auteur:  F.Hourdin
    5 !            F. Codron 01/09
    6 !=======================================================================
     3  !=======================================================================
     4  !   Auteur:  F.Hourdin
     5  !            F. Codron 01/09
     6  !=======================================================================
    77
    88  USE getparam, ONLY: ini_getparam, fin_getparam, getpar
    99  USE Write_Field_loc
    10   use netcdf, ONLY: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close, &
     10  USE netcdf, ONLY: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close, &
    1111          nf90_inq_dimid, nf90_inquire_dimension, nf90_inq_dimid, &
    1212          nf90_inquire_dimension, nf90_enddef, nf90_def_dim, nf90_put_var, nf90_noerr, nf90_close, nf90_inq_varid, &
    … …  
    1414          nf90_create, nf90_def_var, nf90_open
    1515  USE parallel_lmdz
    16   USE pres2lev_mod, ONLY: pres2lev
     16  USE lmdz_pres2lev, ONLY: pres2lev
    1717
    1818  IMPLICIT NONE
    1919
    20 ! ---------------------------------------------
    21 ! Declarations des cles logiques et parametres
    22 ! ---------------------------------------------
    23   INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
    24   INTEGER, PRIVATE, SAVE  :: nlevnc, guide_plevs
    25   LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
    26   LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta 
    27   LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon
    28   LOGICAL, PRIVATE, SAVE  :: invert_p,invert_y,ini_anal
    29   LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav,guide_modele
    30 !FC
    31   LOGICAL, PRIVATE, SAVE  :: convert_Pa
    32  
    33   REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
    34   REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
    35   REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
    36   REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
    37   REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
    38 
    39   REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
    40   REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
    41   REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
    42 
    43   REAL, PRIVATE, SAVE     :: plim_guide_BL
    44 
    45   REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v
    46   REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q
    47   REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
    48  
    49 ! ---------------------------------------------
    50 ! Variables de guidage
    51 ! ---------------------------------------------
    52 ! Variables des fichiers de guidage
    53   REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
    54   REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
    55   REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
    56   REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
    57   REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: pnat1,pnat2
    58   REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
    59   REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
    60 ! Variables aux dimensions du modele
    61   REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
    62   REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
    63   REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
    64   REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
    65   REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
    66  
    67   INTEGER,SAVE,PRIVATE :: ijbu,ijbv,ijeu,ijev !,ijnu,ijnv
    68   INTEGER,SAVE,PRIVATE :: jjbu,jjbv,jjeu,jjev,jjnu,jjnv
     20  ! ---------------------------------------------
     21  ! Declarations des cles logiques et parametres
     22  ! ---------------------------------------------
     23  INTEGER, PRIVATE, SAVE :: iguide_read, iguide_int, iguide_sav
     24  INTEGER, PRIVATE, SAVE :: nlevnc, guide_plevs
     25  LOGICAL, PRIVATE, SAVE :: guide_u, guide_v, guide_T, guide_Q, guide_P
     26  LOGICAL, PRIVATE, SAVE :: guide_hr, guide_teta
     27  LOGICAL, PRIVATE, SAVE :: guide_BL, guide_reg, guide_add, gamma4, guide_zon
     28  LOGICAL, PRIVATE, SAVE :: invert_p, invert_y, ini_anal
     29  LOGICAL, PRIVATE, SAVE :: guide_2D, guide_sav, guide_modele
     30  !FC
     31  LOGICAL, PRIVATE, SAVE :: convert_Pa
     32
     33  REAL, PRIVATE, SAVE :: tau_min_u, tau_max_u
     34  REAL, PRIVATE, SAVE :: tau_min_v, tau_max_v
     35  REAL, PRIVATE, SAVE :: tau_min_T, tau_max_T
     36  REAL, PRIVATE, SAVE :: tau_min_Q, tau_max_Q
     37  REAL, PRIVATE, SAVE :: tau_min_P, tau_max_P
     38
     39  REAL, PRIVATE, SAVE :: lat_min_g, lat_max_g
     40  REAL, PRIVATE, SAVE :: lon_min_g, lon_max_g
     41  REAL, PRIVATE, SAVE :: tau_lon, tau_lat
     42
     43  REAL, PRIVATE, SAVE :: plim_guide_BL
     44
     45  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_u, alpha_v
     46  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_T, alpha_Q
     47  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_P, alpha_pcor
     48
     49  ! ---------------------------------------------
     50  ! Variables de guidage
     51  ! ---------------------------------------------
     52  ! Variables des fichiers de guidage
     53  REAL, ALLOCATABLE, DIMENSION(:, :, :), PRIVATE, SAVE :: unat1, unat2
     54  REAL, ALLOCATABLE, DIMENSION(:, :, :), PRIVATE, SAVE :: vnat1, vnat2
     55  REAL, ALLOCATABLE, DIMENSION(:, :, :), PRIVATE, SAVE :: tnat1, tnat2
     56  REAL, ALLOCATABLE, DIMENSION(:, :, :), PRIVATE, SAVE :: qnat1, qnat2
     57  REAL, ALLOCATABLE, DIMENSION(:, :, :), PRIVATE, SAVE :: pnat1, pnat2
     58  REAL, ALLOCATABLE, DIMENSION(:, :), PRIVATE, SAVE :: psnat1, psnat2
     59  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: apnc, bpnc
     60  ! Variables aux dimensions du modele
     61  REAL, ALLOCATABLE, DIMENSION(:, :), PRIVATE, SAVE :: ugui1, ugui2
     62  REAL, ALLOCATABLE, DIMENSION(:, :), PRIVATE, SAVE :: vgui1, vgui2
     63  REAL, ALLOCATABLE, DIMENSION(:, :), PRIVATE, SAVE :: tgui1, tgui2
     64  REAL, ALLOCATABLE, DIMENSION(:, :), PRIVATE, SAVE :: qgui1, qgui2
     65  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: psgui1, psgui2
     66
     67  INTEGER, SAVE, PRIVATE :: ijbu, ijbv, ijeu, ijev !,ijnu,ijnv
     68  INTEGER, SAVE, PRIVATE :: jjbu, jjbv, jjeu, jjev, jjnu, jjnv
    6969
    7070
    7171CONTAINS
    72 !=======================================================================
     72  !=======================================================================
    7373
    7474  SUBROUTINE guide_init
    … …  
    7878
    7979    IMPLICIT NONE
    80  
     80
    8181    INCLUDE "dimensions.h"
    8282    INCLUDE "paramet.h"
    8383
    84     INTEGER                :: error,ncidpl,rid,rcod
    85     CHARACTER (len = 80)   :: abort_message
    86     CHARACTER (len = 20)   :: modname = 'guide_init'
    87     CHARACTER (len = 20)   :: namedim
    88 
    89 ! ---------------------------------------------
    90 ! Lecture des parametres: 
    91 ! ---------------------------------------------
     84    INTEGER :: error, ncidpl, rid, rcod
     85    CHARACTER (len = 80) :: abort_message
     86    CHARACTER (len = 20) :: modname = 'guide_init'
     87    CHARACTER (len = 20) :: namedim
     88
     89    ! ---------------------------------------------
     90    ! Lecture des parametres:
     91    ! ---------------------------------------------
    9292    CALL ini_getparam("nudging_parameters_out.txt")
    93 ! Variables guidees
    94     CALL getpar('guide_u',.TRUE.,guide_u,'guidage de u')
    95     CALL getpar('guide_v',.TRUE.,guide_v,'guidage de v')
    96     CALL getpar('guide_T',.TRUE.,guide_T,'guidage de T')
    97     CALL getpar('guide_P',.TRUE.,guide_P,'guidage de P')
    98     CALL getpar('guide_Q',.TRUE.,guide_Q,'guidage de Q')
    99     CALL getpar('guide_hr',.TRUE.,guide_hr,'guidage de Q par H.R')
    100     CALL getpar('guide_teta',.FALSE.,guide_teta,'guidage de T par Teta')
    101 
    102     CALL getpar('guide_add',.FALSE.,guide_add,'foréage constant?')
    103     CALL getpar('guide_zon',.FALSE.,guide_zon,'guidage moy zonale')
    104     if (guide_zon .and. abs(grossismx - 1.) > 0.01) &
    105          CALL abort_gcm("guide_init", &
    106          "zonal nudging requires grid regular in longitude", 1)
    107 
    108 !   Constantes de rappel. Unite : fraction de jour
    109     CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
    110     CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
    111     CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
    112     CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
    113     CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
    114     CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
    115     CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
    116     CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
    117     CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
    118     CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
    119     CALL getpar('gamma4',.FALSE.,gamma4,'Zone sans rappel elargie')
    120     CALL getpar('guide_BL',.TRUE.,guide_BL,'guidage dans C.Lim')
    121     CALL getpar('plim_guide_BL',85000.,plim_guide_BL,'BL top presnivs value')
    122 
    123 ! Sauvegarde du forçage
    124     CALL getpar('guide_sav',.FALSE.,guide_sav,'sauvegarde guidage')
    125     CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
     93    ! Variables guidees
     94    CALL getpar('guide_u', .TRUE., guide_u, 'guidage de u')
     95    CALL getpar('guide_v', .TRUE., guide_v, 'guidage de v')
     96    CALL getpar('guide_T', .TRUE., guide_T, 'guidage de T')
     97    CALL getpar('guide_P', .TRUE., guide_P, 'guidage de P')
     98    CALL getpar('guide_Q', .TRUE., guide_Q, 'guidage de Q')
     99    CALL getpar('guide_hr', .TRUE., guide_hr, 'guidage de Q par H.R')
     100    CALL getpar('guide_teta', .FALSE., guide_teta, 'guidage de T par Teta')
     101
     102    CALL getpar('guide_add', .FALSE., guide_add, 'foréage constant?')
     103    CALL getpar('guide_zon', .FALSE., guide_zon, 'guidage moy zonale')
     104    IF (guide_zon .AND. abs(grossismx - 1.) > 0.01) &
     105            CALL abort_gcm("guide_init", &
     106                    "zonal nudging requires grid regular in longitude", 1)
     107
     108    !   Constantes de rappel. Unite : fraction de jour
     109    CALL getpar('tau_min_u', 0.02, tau_min_u, 'Cste de rappel min, u')
     110    CALL getpar('tau_max_u', 10., tau_max_u, 'Cste de rappel max, u')
     111    CALL getpar('tau_min_v', 0.02, tau_min_v, 'Cste de rappel min, v')
     112    CALL getpar('tau_max_v', 10., tau_max_v, 'Cste de rappel max, v')
     113    CALL getpar('tau_min_T', 0.02, tau_min_T, 'Cste de rappel min, T')
     114    CALL getpar('tau_max_T', 10., tau_max_T, 'Cste de rappel max, T')
     115    CALL getpar('tau_min_Q', 0.02, tau_min_Q, 'Cste de rappel min, Q')
     116    CALL getpar('tau_max_Q', 10., tau_max_Q, 'Cste de rappel max, Q')
     117    CALL getpar('tau_min_P', 0.02, tau_min_P, 'Cste de rappel min, P')
     118    CALL getpar('tau_max_P', 10., tau_max_P, 'Cste de rappel max, P')
     119    CALL getpar('gamma4', .FALSE., gamma4, 'Zone sans rappel elargie')
     120    CALL getpar('guide_BL', .TRUE., guide_BL, 'guidage dans C.Lim')
     121    CALL getpar('plim_guide_BL', 85000., plim_guide_BL, 'BL top presnivs value')
     122
     123    ! Sauvegarde du forçage
     124    CALL getpar('guide_sav', .FALSE., guide_sav, 'sauvegarde guidage')
     125    CALL getpar('iguide_sav', 4, iguide_sav, 'freq. sauvegarde guidage')
    126126    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
    127127    IF (iguide_sav>0) THEN
    128        iguide_sav=day_step/iguide_sav
     128      iguide_sav = day_step / iguide_sav
    129129    ELSE if (iguide_sav == 0) THEN
    130        iguide_sav = huge(0)
     130      iguide_sav = huge(0)
    131131    ELSE
    132        iguide_sav=day_step*iguide_sav
    133     ENDIF
    134 
    135 ! Guidage regional seulement (sinon constant ou suivant le zoom)
    136     CALL getpar('guide_reg',.FALSE.,guide_reg,'guidage regional')
    137     CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
    138     CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
    139     CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
    140     CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
    141     CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
    142     CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
    143 
    144 ! Parametres pour lecture des fichiers
    145     CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
    146     CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
     132      iguide_sav = day_step * iguide_sav
     133    ENDIF
     134
     135    ! Guidage regional seulement (sinon constant ou suivant le zoom)
     136    CALL getpar('guide_reg', .FALSE., guide_reg, 'guidage regional')
     137    CALL getpar('lat_min_g', -90., lat_min_g, 'Latitude mini guidage ')
     138    CALL getpar('lat_max_g', 90., lat_max_g, 'Latitude maxi guidage ')
     139    CALL getpar('lon_min_g', -180., lon_min_g, 'longitude mini guidage ')
     140    CALL getpar('lon_max_g', 180., lon_max_g, 'longitude maxi guidage ')
     141    CALL getpar('tau_lat', 5., tau_lat, 'raideur lat guide regional ')
     142    CALL getpar('tau_lon', 5., tau_lon, 'raideur lon guide regional ')
     143
     144    ! Parametres pour lecture des fichiers
     145    CALL getpar('iguide_read', 4, iguide_read, 'freq. lecture guidage')
     146    CALL getpar('iguide_int', 4, iguide_int, 'freq. interpolation vert')
    147147    IF (iguide_int==0) THEN
    148         iguide_int=1
     148      iguide_int = 1
    149149    ELSEIF (iguide_int>0) THEN
    150         iguide_int=day_step/iguide_int
     150      iguide_int = day_step / iguide_int
    151151    ELSE
    152         iguide_int=day_step*iguide_int
    153     ENDIF
    154     CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
     152      iguide_int = day_step * iguide_int
     153    ENDIF
     154    CALL getpar('guide_plevs', 0, guide_plevs, 'niveaux pression fichiers guidage')
    155155    ! Pour compatibilite avec ancienne version avec guide_modele
    156     CALL getpar('guide_modele',.FALSE.,guide_modele,'niveaux pression ap+bp*psol')
     156    CALL getpar('guide_modele', .FALSE., guide_modele, 'niveaux pression ap+bp*psol')
    157157    IF (guide_modele) THEN
    158         guide_plevs=1
    159     ENDIF
    160 !FC
    161     CALL getpar('convert_Pa',.TRUE.,convert_Pa,'Convert Pressure levels in Pa')
     158      guide_plevs = 1
     159    ENDIF
     160    !FC
     161    CALL getpar('convert_Pa', .TRUE., convert_Pa, 'Convert Pressure levels in Pa')
    162162    ! Fin raccord
    163     CALL getpar('ini_anal',.FALSE.,ini_anal,'Etat initial = analyse')
    164     CALL getpar('guide_invertp',.TRUE.,invert_p,'niveaux p inverses')
    165     CALL getpar('guide_inverty',.TRUE.,invert_y,'inversion N-S')
    166     CALL getpar('guide_2D',.FALSE.,guide_2D,'fichier guidage lat-P')
     163    CALL getpar('ini_anal', .FALSE., ini_anal, 'Etat initial = analyse')
     164    CALL getpar('guide_invertp', .TRUE., invert_p, 'niveaux p inverses')
     165    CALL getpar('guide_inverty', .TRUE., invert_y, 'inversion N-S')
     166    CALL getpar('guide_2D', .FALSE., guide_2D, 'fichier guidage lat-P')
    167167
    168168    CALL fin_getparam
    169    
    170 ! ---------------------------------------------
    171 ! Determination du nombre de niveaux verticaux
    172 ! des fichiers guidage
    173 ! ---------------------------------------------
    174     ncidpl=-99
    175     if (guide_plevs==1) THEN
    176        if (ncidpl==-99) THEN
    177           rcod=nf90_open('apbp.nc',nf90_nowrite, ncidpl)
    178           if (rcod/=nf90_noerr) THEN
    179              abort_message=' Nudging error -> no file apbp.nc'
    180              CALL abort_gcm(modname,abort_message,1)
    181           endif
    182        endif
     169
     170    ! ---------------------------------------------
     171    ! Determination du nombre de niveaux verticaux
     172    ! des fichiers guidage
     173    ! ---------------------------------------------
     174    ncidpl = -99
     175    IF (guide_plevs==1) THEN
     176      IF (ncidpl==-99) THEN
     177        rcod = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
     178        IF (rcod/=nf90_noerr) THEN
     179          abort_message = ' Nudging error -> no file apbp.nc'
     180          CALL abort_gcm(modname, abort_message, 1)
     181        endif
     182      endif
    183183    elseif (guide_plevs==2) THEN
    184        if (ncidpl==-99) THEN
    185           rcod=nf90_open('P.nc',nf90_nowrite,ncidpl)
    186           if (rcod/=nf90_noerr) THEN
    187              abort_message=' Nudging error -> no file P.nc'
    188              CALL abort_gcm(modname,abort_message,1)
    189           endif
    190        endif
     184      IF (ncidpl==-99) THEN
     185        rcod = nf90_open('P.nc', nf90_nowrite, ncidpl)
     186        IF (rcod/=nf90_noerr) THEN
     187          abort_message = ' Nudging error -> no file P.nc'
     188          CALL abort_gcm(modname, abort_message, 1)
     189        endif
     190      endif
    191191
    192192    elseif (guide_u) THEN
    193        if (ncidpl==-99) THEN
    194           rcod=nf90_open('u.nc',nf90_nowrite,ncidpl)
    195           if (rcod/=nf90_noerr) THEN
    196              abort_message=' Nudging error -> no file u.nc'
    197              CALL abort_gcm(modname,abort_message,1)
    198           endif
    199          
    200        endif
    201 
     193      IF (ncidpl==-99) THEN
     194        rcod = nf90_open('u.nc', nf90_nowrite, ncidpl)
     195        IF (rcod/=nf90_noerr) THEN
     196          abort_message = ' Nudging error -> no file u.nc'
     197          CALL abort_gcm(modname, abort_message, 1)
     198        endif
     199
     200      endif
    202201
    203202    elseif (guide_v) THEN
    204        if (ncidpl==-99) THEN
    205           rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
    206           if (rcod/=nf90_noerr) THEN
    207              abort_message=' Nudging error -> no file v.nc'
    208              CALL abort_gcm(modname,abort_message,1)
    209           endif
    210        endif
    211 
    212    
     203      IF (ncidpl==-99) THEN
     204        rcod = nf90_open('v.nc', nf90_nowrite, ncidpl)
     205        IF (rcod/=nf90_noerr) THEN
     206          abort_message = ' Nudging error -> no file v.nc'
     207          CALL abort_gcm(modname, abort_message, 1)
     208        endif
     209      endif
     210
    213211    elseif (guide_T) THEN
    214        if (ncidpl==-99) THEN
    215           rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
    216           if (rcod/=nf90_noerr) THEN
    217              abort_message=' Nudging error -> no file T.nc'
    218              CALL abort_gcm(modname,abort_message,1)
    219           endif
    220        endif
    221 
    222 
     212      IF (ncidpl==-99) THEN
     213        rcod = nf90_open('T.nc', nf90_nowrite, ncidpl)
     214        IF (rcod/=nf90_noerr) THEN
     215          abort_message = ' Nudging error -> no file T.nc'
     216          CALL abort_gcm(modname, abort_message, 1)
     217        endif
     218      endif
    223219
    224220    elseif (guide_Q) THEN
    225        if (ncidpl==-99) THEN
    226           rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
    227           if (rcod/=nf90_noerr) THEN
    228              abort_message=' Nudging error -> no file hur.nc'
    229              CALL abort_gcm(modname,abort_message,1)
    230           endif
    231        endif
    232 
    233 
    234     endif
    235     error=nf90_inq_dimid(ncidpl,'LEVEL',rid)
    236     IF (error/=nf90_noerr) error=nf90_inq_dimid(ncidpl,'PRESSURE',rid)
     221      IF (ncidpl==-99) THEN
     222        rcod = nf90_open('hur.nc', nf90_nowrite, ncidpl)
     223        IF (rcod/=nf90_noerr) THEN
     224          abort_message = ' Nudging error -> no file hur.nc'
     225          CALL abort_gcm(modname, abort_message, 1)
     226        endif
     227      endif
     228
     229    endif
     230    error = nf90_inq_dimid(ncidpl, 'LEVEL', rid)
     231    IF (error/=nf90_noerr) error = nf90_inq_dimid(ncidpl, 'PRESSURE', rid)
    237232    IF (error/=nf90_noerr) THEN
    238         abort_message='Nudging: error reading pressure levels'
    239         CALL abort_gcm(modname,abort_message,1)
    240     ENDIF
    241     error=nf90_inquire_dimension(ncidpl,rid,len=nlevnc)
    242     WRITE(*,*)trim(modname)//' : number of vertical levels nlevnc', nlevnc
     233      abort_message = 'Nudging: error reading pressure levels'
     234      CALL abort_gcm(modname, abort_message, 1)
     235    ENDIF
     236    error = nf90_inquire_dimension(ncidpl, rid, len = nlevnc)
     237    WRITE(*, *)trim(modname) // ' : number of vertical levels nlevnc', nlevnc
    243238    rcod = nf90_close(ncidpl)
    244239
    245 ! ---------------------------------------------
    246 ! Allocation des variables
    247 ! ---------------------------------------------
    248     abort_message='nudging allocation error'
     240    ! ---------------------------------------------
     241    ! Allocation des variables
     242    ! ---------------------------------------------
     243    abort_message = 'nudging allocation error'
    249244
    250245    ALLOCATE(apnc(nlevnc), stat = error)
    251     IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
     246    IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
    252247    ALLOCATE(bpnc(nlevnc), stat = error)
    253     IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    254     apnc=0.;bpnc=0.
     248    IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     249    apnc = 0.;bpnc = 0.
    255250
    256251    ALLOCATE(alpha_pcor(llm), stat = error)
    257     IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
     252    IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
    258253    ALLOCATE(alpha_u(ijb_u:ije_u), stat = error)
    259     IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
     254    IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
    260255    ALLOCATE(alpha_v(ijb_v:ije_v), stat = error)
    261     IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
     256    IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
    262257    ALLOCATE(alpha_T(ijb_u:ije_u), stat = error)
    263     IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
     258    IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
    264259    ALLOCATE(alpha_Q(ijb_u:ije_u), stat = error)
    265     IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
     260    IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
    266261    ALLOCATE(alpha_P(ijb_u:ije_u), stat = error)
    267     IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    268     alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
    269    
     262    IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     263    alpha_u = 0.;alpha_v = 0;alpha_T = 0;alpha_Q = 0;alpha_P = 0
     264
    270265    IF (guide_u) THEN
    271         ALLOCATE(unat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
    272         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    273         ALLOCATE(ugui1(ijb_u:ije_u,llm), stat = error)
    274         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    275         ALLOCATE(unat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
    276         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    277         ALLOCATE(ugui2(ijb_u:ije_u,llm), stat = error)
    278         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    279         unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
     266      ALLOCATE(unat1(iip1, jjb_u:jje_u, nlevnc), stat = error)
     267      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     268      ALLOCATE(ugui1(ijb_u:ije_u, llm), stat = error)
     269      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     270      ALLOCATE(unat2(iip1, jjb_u:jje_u, nlevnc), stat = error)
     271      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     272      ALLOCATE(ugui2(ijb_u:ije_u, llm), stat = error)
     273      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     274      unat1 = 0.;unat2 = 0.;ugui1 = 0.;ugui2 = 0.
    280275    ENDIF
    281276
    282277    IF (guide_T) THEN
    283         ALLOCATE(tnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
    284         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    285         ALLOCATE(tgui1(ijb_u:ije_u,llm), stat = error)
    286         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    287         ALLOCATE(tnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
    288         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    289         ALLOCATE(tgui2(ijb_u:ije_u,llm), stat = error)
    290         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    291         tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
    292     ENDIF
    293      
     278      ALLOCATE(tnat1(iip1, jjb_u:jje_u, nlevnc), stat = error)
     279      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     280      ALLOCATE(tgui1(ijb_u:ije_u, llm), stat = error)
     281      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     282      ALLOCATE(tnat2(iip1, jjb_u:jje_u, nlevnc), stat = error)
     283      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     284      ALLOCATE(tgui2(ijb_u:ije_u, llm), stat = error)
     285      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     286      tnat1 = 0.;tnat2 = 0.;tgui1 = 0.;tgui2 = 0.
     287    ENDIF
     288
    294289    IF (guide_Q) THEN
    295         ALLOCATE(qnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
    296         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    297         ALLOCATE(qgui1(ijb_u:ije_u,llm), stat = error)
    298         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    299         ALLOCATE(qnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
    300         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    301         ALLOCATE(qgui2(ijb_u:ije_u,llm), stat = error)
    302         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    303         qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
     290      ALLOCATE(qnat1(iip1, jjb_u:jje_u, nlevnc), stat = error)
     291      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     292      ALLOCATE(qgui1(ijb_u:ije_u, llm), stat = error)
     293      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     294      ALLOCATE(qnat2(iip1, jjb_u:jje_u, nlevnc), stat = error)
     295      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     296      ALLOCATE(qgui2(ijb_u:ije_u, llm), stat = error)
     297      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     298      qnat1 = 0.;qnat2 = 0.;qgui1 = 0.;qgui2 = 0.
    304299    ENDIF
    305300
    306301    IF (guide_v) THEN
    307         ALLOCATE(vnat1(iip1,jjb_v:jje_v,nlevnc), stat = error)
    308         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    309         ALLOCATE(vgui1(ijb_v:ije_v,llm), stat = error)
    310         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    311         ALLOCATE(vnat2(iip1,jjb_v:jje_v,nlevnc), stat = error)
    312         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    313         ALLOCATE(vgui2(ijb_v:ije_v,llm), stat = error)
    314         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    315         vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
     302      ALLOCATE(vnat1(iip1, jjb_v:jje_v, nlevnc), stat = error)
     303      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     304      ALLOCATE(vgui1(ijb_v:ije_v, llm), stat = error)
     305      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     306      ALLOCATE(vnat2(iip1, jjb_v:jje_v, nlevnc), stat = error)
     307      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     308      ALLOCATE(vgui2(ijb_v:ije_v, llm), stat = error)
     309      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     310      vnat1 = 0.;vnat2 = 0.;vgui1 = 0.;vgui2 = 0.
    316311    ENDIF
    317312
    318313    IF (guide_plevs==2) THEN
    319         ALLOCATE(pnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
    320         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    321         ALLOCATE(pnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
    322         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    323         pnat1=0.;pnat2=0.;
     314      ALLOCATE(pnat1(iip1, jjb_u:jje_u, nlevnc), stat = error)
     315      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     316      ALLOCATE(pnat2(iip1, jjb_u:jje_u, nlevnc), stat = error)
     317      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     318      pnat1 = 0.;pnat2 = 0.;
    324319    ENDIF
    325320
    326321    IF (guide_P.OR.guide_plevs==1) THEN
    327         ALLOCATE(psnat1(iip1,jjb_u:jje_u), stat = error)
    328         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    329         ALLOCATE(psnat2(iip1,jjb_u:jje_u), stat = error)
    330         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    331         psnat1=0.;psnat2=0.;
     322      ALLOCATE(psnat1(iip1, jjb_u:jje_u), stat = error)
     323      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     324      ALLOCATE(psnat2(iip1, jjb_u:jje_u), stat = error)
     325      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     326      psnat1 = 0.;psnat2 = 0.;
    332327    ENDIF
    333328    IF (guide_P) THEN
    334         ALLOCATE(psgui2(ijb_u:ije_u), stat = error)
    335         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    336         ALLOCATE(psgui1(ijb_u:ije_u), stat = error)
    337         IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
    338         psgui1=0.;psgui2=0.
    339     ENDIF
    340 
    341 ! ---------------------------------------------
    342 !   Lecture du premier etat de guidage.
    343 ! ---------------------------------------------
     329      ALLOCATE(psgui2(ijb_u:ije_u), stat = error)
     330      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     331      ALLOCATE(psgui1(ijb_u:ije_u), stat = error)
     332      IF (error /= 0) CALL abort_gcm(modname, abort_message, 1)
     333      psgui1 = 0.;psgui2 = 0.
     334    ENDIF
     335
     336    ! ---------------------------------------------
     337    !   Lecture du premier etat de guidage.
     338    ! ---------------------------------------------
    344339    IF (guide_2D) THEN
    345         CALL guide_read2D(1)
     340      CALL guide_read2D(1)
    346341    ELSE
    347         CALL guide_read(1)
    348     ENDIF
    349     IF (guide_v) vnat1=vnat2
    350     IF (guide_u) unat1=unat2
    351     IF (guide_T) tnat1=tnat2
    352     IF (guide_Q) qnat1=qnat2
    353     IF (guide_plevs==2) pnat1=pnat2
    354     IF (guide_P.OR.guide_plevs==1) psnat1=psnat2
     342      CALL guide_read(1)
     343    ENDIF
     344    IF (guide_v) vnat1 = vnat2
     345    IF (guide_u) unat1 = unat2
     346    IF (guide_T) tnat1 = tnat2
     347    IF (guide_Q) qnat1 = qnat2
     348    IF (guide_plevs==2) pnat1 = pnat2
     349    IF (guide_P.OR.guide_plevs==1) psnat1 = psnat2
    355350
    356351  END SUBROUTINE guide_init
    357352
    358 !=======================================================================
    359   SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
    360     use exner_hyb_loc_m, ONLY: exner_hyb_loc
    361     use exner_milieu_loc_m, ONLY: exner_milieu_loc
     353  !=======================================================================
     354  SUBROUTINE guide_main(itau, ucov, vcov, teta, q, masse, ps)
     355    USE exner_hyb_loc_m, ONLY: exner_hyb_loc
     356    USE exner_milieu_loc_m, ONLY: exner_milieu_loc
    362357    USE parallel_lmdz
    363358    USE control_mod
    … …  
    365360    USE comconst_mod, ONLY: cpp, daysec, dtvr, kappa
    366361    USE comvert_mod, ONLY: ap, bp, preff, presnivs, pressure_exner
    367    
     362
    368363    IMPLICIT NONE
    369  
     364
    370365    INCLUDE "dimensions.h"
    371366    INCLUDE "paramet.h"
    372367
    373368    ! Variables entree
    374     INTEGER,                           INTENT(IN)    :: itau !pas de temps
    375     REAL, DIMENSION (ijb_u:ije_u,llm), INTENT(INOUT) :: ucov,teta,q,masse
    376     REAL, DIMENSION (ijb_v:ije_v,llm), INTENT(INOUT) :: vcov
    377     REAL, DIMENSION (ijb_u:ije_u),     INTENT(INOUT) :: ps
     369    INTEGER, INTENT(IN) :: itau !pas de temps
     370    REAL, DIMENSION (ijb_u:ije_u, llm), INTENT(INOUT) :: ucov, teta, q, masse
     371    REAL, DIMENSION (ijb_v:ije_v, llm), INTENT(INOUT) :: vcov
     372    REAL, DIMENSION (ijb_u:ije_u), INTENT(INOUT) :: ps
    378373
    379374    ! Variables locales
    380     LOGICAL, SAVE :: first=.TRUE.
    381 !$OMP THREADPRIVATE(first)
    382     LOGICAL       :: f_out ! sortie guidage
    383     REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addu ! var aux: champ de guidage
    384     REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addv ! var aux: champ de guidage
     375    LOGICAL, SAVE :: first = .TRUE.
     376    !$OMP THREADPRIVATE(first)
     377    LOGICAL :: f_out ! sortie guidage
     378    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: f_addu ! var aux: champ de guidage
     379    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: f_addv ! var aux: champ de guidage
    385380    ! Variables pour fonction Exner (P milieu couche)
    386     REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)    :: pk
    387     REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)        :: pks   
    388     REAL                               :: unskap
    389     REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)    :: p ! besoin si guide_P
     381    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: pk
     382    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: pks
     383    REAL :: unskap
     384    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: p ! besoin si guide_P
    390385    ! Compteurs temps:
    391     INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
    392 !$OMP THREADPRIVATE(step_rea,count_no_rea,itau_test)
    393     REAL          :: ditau, dday_step
    394     REAL          :: tau,reste ! position entre 2 etats de guidage
    395     REAL, SAVE    :: factt ! pas de temps en fraction de jour
    396 !$OMP THREADPRIVATE(factt)
    397    
    398     INTEGER       :: i,j,l
    399     CHARACTER(LEN=20) :: modname="guide_main"
    400        
    401 !$OMP MASTER   
    402     ijbu=ij_begin ; ijeu=ij_end
    403     jjbu=jj_begin ; jjeu=jj_end ; jjnu=jjeu-jjbu+1
    404     ijbv=ij_begin ; ijev=ij_end
    405     jjbv=jj_begin ; jjev=jj_end ; jjnv=jjev-jjbv+1
     386    INTEGER, SAVE :: step_rea, count_no_rea, itau_test ! lecture guidage
     387    !$OMP THREADPRIVATE(step_rea,count_no_rea,itau_test)
     388    REAL :: ditau, dday_step
     389    REAL :: tau, reste ! position entre 2 etats de guidage
     390    REAL, SAVE :: factt ! pas de temps en fraction de jour
     391    !$OMP THREADPRIVATE(factt)
     392
     393    INTEGER :: i, j, l
     394    CHARACTER(LEN = 20) :: modname = "guide_main"
     395
     396    !$OMP MASTER
     397    ijbu = ij_begin ; ijeu = ij_end
     398    jjbu = jj_begin ; jjeu = jj_end ; jjnu = jjeu - jjbu + 1
     399    ijbv = ij_begin ; ijev = ij_end
     400    jjbv = jj_begin ; jjev = jj_end ; jjnv = jjev - jjbv + 1
    406401    IF (pole_sud) THEN
    407       ijeu=ij_end-iip1
    408       ijev=ij_end-iip1
    409       jjev=jj_end-1
    410       jjnv=jjev-jjbv+1
     402      ijeu = ij_end - iip1
     403      ijev = ij_end - iip1
     404      jjev = jj_end - 1
     405      jjnv = jjev - jjbv + 1
    411406    ENDIF
    412407    IF (pole_nord) THEN
    413       ijbu=ij_begin+iip1
    414       ijbv=ij_begin
    415     ENDIF
    416 !$OMP END MASTER
    417 !$OMP BARRIER
    418      
    419 !    PRINT *,'---> on rentre dans guide_main'
    420 !    CALL AllGather_Field(ucov,ip1jmp1,llm)
    421 !    CALL AllGather_Field(vcov,ip1jm,llm)
    422 !    CALL AllGather_Field(teta,ip1jmp1,llm)
    423 !    CALL AllGather_Field(ps,ip1jmp1,1)
    424 !    CALL AllGather_Field(q,ip1jmp1,llm)
    425    
    426 !-----------------------------------------------------------------------
    427 ! Initialisations au premier passage
    428 !-----------------------------------------------------------------------
     408      ijbu = ij_begin + iip1
     409      ijbv = ij_begin
     410    ENDIF
     411    !$OMP END MASTER
     412    !$OMP BARRIER
     413
     414    !    PRINT *,'---> on rentre dans guide_main'
     415    !    CALL AllGather_Field(ucov,ip1jmp1,llm)
     416    !    CALL AllGather_Field(vcov,ip1jm,llm)
     417    !    CALL AllGather_Field(teta,ip1jmp1,llm)
     418    !    CALL AllGather_Field(ps,ip1jmp1,1)
     419    !    CALL AllGather_Field(q,ip1jmp1,llm)
     420
     421    !-----------------------------------------------------------------------
     422    ! Initialisations au premier passage
     423    !-----------------------------------------------------------------------
    429424
    430425    IF (first) THEN
    431         first=.FALSE.
    432 !$OMP MASTER
    433         ALLOCATE(f_addu(ijb_u:ije_u,llm) )
    434         ALLOCATE(f_addv(ijb_v:ije_v,llm) )
    435         ALLOCATE(pk(iip1,jjb_u:jje_u,llm)  )
    436         ALLOCATE(pks(iip1,jjb_u:jje_u)  )
    437         ALLOCATE(p(ijb_u:ije_u,llmp1) )
    438         CALL guide_init
    439 !$OMP END MASTER
    440 !$OMP BARRIER
    441         itau_test=1001
    442         step_rea=1
    443         count_no_rea=0
    444 ! Calcul des constantes de rappel
    445         factt=dtvr*iperiod/daysec
    446 !$OMP MASTER
    447         CALL tau2alpha(3, iip1, jjb_v, jje_v, factt, tau_min_v, tau_max_v, alpha_v)
    448         CALL tau2alpha(2, iip1, jjb_u, jje_u, factt, tau_min_u, tau_max_u, alpha_u)
    449         CALL tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_T, tau_max_T, alpha_T)
    450         CALL tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_P, tau_max_P, alpha_P)
    451         CALL tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_Q, tau_max_Q, alpha_Q)
    452 ! correction de rappel dans couche limite
    453         if (guide_BL) THEN
    454              alpha_pcor(:)=1.
    455         else
    456             do l=1,llm
    457                 alpha_pcor(l)=(1.+tanh(((plim_guide_BL-presnivs(l))/preff)/0.05))/2.
    458             enddo
    459         endif
    460 !$OMP END MASTER
    461 !$OMP BARRIER
    462 ! ini_anal: etat initial egal au guidage       
    463         IF (ini_anal) THEN
    464             CALL guide_interp(ps,teta)
    465 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
    466             DO l=1,llm
    467               IF (guide_u) ucov(ijbu:ijeu,l)=ugui2(ijbu:ijeu,l)
    468               IF (guide_v) vcov(ijbv:ijev,l)=ugui2(ijbv:ijev,l)
    469               IF (guide_T) teta(ijbu:ijeu,l)=tgui2(ijbu:ijeu,l)
    470               IF (guide_Q) q(ijbu:ijeu,l)=qgui2(ijbu:ijeu,l)
    471             ENDDO
    472            
    473             IF (guide_P) THEN
    474 !$OMP MASTER
    475                 ps(ijbu:ijeu)=psgui2(ijbu:ijeu)
    476 !$OMP END MASTER
    477 !$OMP BARRIER
    478                 CALL pression_loc(ijnb_u,ap,bp,ps,p)
    479                 CALL massdair_loc(p,masse)
    480 !$OMP BARRIER
    481             ENDIF
    482             RETURN
    483         ENDIF
     426      first = .FALSE.
     427      !$OMP MASTER
     428      ALLOCATE(f_addu(ijb_u:ije_u, llm))
     429      ALLOCATE(f_addv(ijb_v:ije_v, llm))
     430      ALLOCATE(pk(iip1, jjb_u:jje_u, llm))
     431      ALLOCATE(pks(iip1, jjb_u:jje_u))
     432      ALLOCATE(p(ijb_u:ije_u, llmp1))
     433      CALL guide_init
     434      !$OMP END MASTER
     435      !$OMP BARRIER
     436      itau_test = 1001
     437      step_rea = 1
     438      count_no_rea = 0
     439      ! Calcul des constantes de rappel
     440      factt = dtvr * iperiod / daysec
     441      !$OMP MASTER
     442      CALL tau2alpha(3, iip1, jjb_v, jje_v, factt, tau_min_v, tau_max_v, alpha_v)
     443      CALL tau2alpha(2, iip1, jjb_u, jje_u, factt, tau_min_u, tau_max_u, alpha_u)
     444      CALL tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_T, tau_max_T, alpha_T)
     445      CALL tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_P, tau_max_P, alpha_P)
     446      CALL tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_Q, tau_max_Q, alpha_Q)
     447      ! correction de rappel dans couche limite
     448      IF (guide_BL) THEN
     449        alpha_pcor(:) = 1.
     450      else
     451        do l = 1, llm
     452          alpha_pcor(l) = (1. + tanh(((plim_guide_BL - presnivs(l)) / preff) / 0.05)) / 2.
     453        enddo
     454      endif
     455      !$OMP END MASTER
     456      !$OMP BARRIER
     457      ! ini_anal: etat initial egal au guidage
     458      IF (ini_anal) THEN
     459        CALL guide_interp(ps, teta)
     460        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     461        DO l = 1, llm
     462          IF (guide_u) ucov(ijbu:ijeu, l) = ugui2(ijbu:ijeu, l)
     463          IF (guide_v) vcov(ijbv:ijev, l) = ugui2(ijbv:ijev, l)
     464          IF (guide_T) teta(ijbu:ijeu, l) = tgui2(ijbu:ijeu, l)
     465          IF (guide_Q) q(ijbu:ijeu, l) = qgui2(ijbu:ijeu, l)
     466        ENDDO
     467
     468        IF (guide_P) THEN
     469          !$OMP MASTER
     470          ps(ijbu:ijeu) = psgui2(ijbu:ijeu)
     471          !$OMP END MASTER
     472          !$OMP BARRIER
     473          CALL pression_loc(ijnb_u, ap, bp, ps, p)
     474          CALL massdair_loc(p, masse)
     475          !$OMP BARRIER
     476        ENDIF
     477        RETURN
     478      ENDIF
    484479
    485480    ENDIF !first
    486481
    487 !-----------------------------------------------------------------------
    488 ! Lecture des fichiers de guidage ?
    489 !-----------------------------------------------------------------------
     482    !-----------------------------------------------------------------------
     483    ! Lecture des fichiers de guidage ?
     484    !-----------------------------------------------------------------------
    490485    IF (iguide_read/=0) THEN
    491       ditau=real(itau)
    492       dday_step=real(day_step)
     486      ditau = real(itau)
     487      dday_step = real(day_step)
    493488      IF (iguide_read<0) THEN
    494           tau=ditau/dday_step/REAL(iguide_read)
     489        tau = ditau / dday_step / REAL(iguide_read)
    495490      ELSE
    496           tau=REAL(iguide_read)*ditau/dday_step
    497       ENDIF
    498       reste=tau-AINT(tau)
     491        tau = REAL(iguide_read) * ditau / dday_step
     492      ENDIF
     493      reste = tau - AINT(tau)
    499494      IF (reste==0.) THEN
    500           IF (itau_test==itau) THEN
    501             WRITE(*,*)trim(modname)//' second pass in advreel at itau=',&
    502             itau
    503             CALL abort_gcm("guide_loc_lod","stopped",1)
     495        IF (itau_test==itau) THEN
     496          WRITE(*, *)trim(modname) // ' second pass in advreel at itau=', &
     497                  itau
     498          CALL abort_gcm("guide_loc_lod", "stopped", 1)
     499        ELSE
     500          !$OMP MASTER
     501          IF (guide_v) vnat1(:, jjbv:jjev, :) = vnat2(:, jjbv:jjev, :)
     502          IF (guide_u) unat1(:, jjbu:jjeu, :) = unat2(:, jjbu:jjeu, :)
     503          IF (guide_T) tnat1(:, jjbu:jjeu, :) = tnat2(:, jjbu:jjeu, :)
     504          IF (guide_Q) qnat1(:, jjbu:jjeu, :) = qnat2(:, jjbu:jjeu, :)
     505          IF (guide_plevs==2) pnat1(:, jjbu:jjeu, :) = pnat2(:, jjbu:jjeu, :)
     506          IF (guide_P.OR.guide_plevs==1) psnat1(:, jjbu:jjeu) = psnat2(:, jjbu:jjeu)
     507          !$OMP END MASTER
     508          !$OMP BARRIER
     509          step_rea = step_rea + 1
     510          itau_test = itau
     511          IF (is_master) THEN
     512            WRITE(*, *)trim(modname) // ' Reading nudging files, step ', &
     513                    step_rea, 'after ', count_no_rea, ' skips'
     514          endif
     515          IF (guide_2D) THEN
     516            !$OMP MASTER
     517            CALL guide_read2D(step_rea)
     518            !$OMP END MASTER
     519            !$OMP BARRIER
    504520          ELSE
    505 !$OMP MASTER
    506               IF (guide_v) vnat1(:,jjbv:jjev,:)=vnat2(:,jjbv:jjev,:)
    507               IF (guide_u) unat1(:,jjbu:jjeu,:)=unat2(:,jjbu:jjeu,:)
    508               IF (guide_T) tnat1(:,jjbu:jjeu,:)=tnat2(:,jjbu:jjeu,:)
    509               IF (guide_Q) qnat1(:,jjbu:jjeu,:)=qnat2(:,jjbu:jjeu,:)
    510               IF (guide_plevs==2) pnat1(:,jjbu:jjeu,:)=pnat2(:,jjbu:jjeu,:)
    511               IF (guide_P.OR.guide_plevs==1) psnat1(:,jjbu:jjeu)=psnat2(:,jjbu:jjeu)
    512 !$OMP END MASTER
    513 !$OMP BARRIER
    514               step_rea=step_rea+1
    515               itau_test=itau
    516               if (is_master) THEN
    517                 WRITE(*,*)trim(modname)//' Reading nudging files, step ',&
    518                     step_rea,'after ',count_no_rea,' skips'
    519               endif
    520               IF (guide_2D) THEN
    521 !$OMP MASTER
    522                   CALL guide_read2D(step_rea)
    523 !$OMP END MASTER
    524 !$OMP BARRIER
    525               ELSE
    526 !$OMP MASTER
    527                   CALL guide_read(step_rea)
    528 !$OMP END MASTER
    529 !$OMP BARRIER
    530               ENDIF
    531               count_no_rea=0
     521            !$OMP MASTER
     522            CALL guide_read(step_rea)
     523            !$OMP END MASTER
     524            !$OMP BARRIER
    532525          ENDIF
     526          count_no_rea = 0
     527        ENDIF
    533528      ELSE
    534         count_no_rea=count_no_rea+1
     529        count_no_rea = count_no_rea + 1
    535530
    536531      ENDIF
    537532    ENDIF !iguide_read=0
    538533
    539 !-----------------------------------------------------------------------
    540 ! Interpolation et conversion des champs de guidage
    541 !-----------------------------------------------------------------------
    542     IF (MOD(itau,iguide_int)==0) THEN
    543         CALL guide_interp(ps,teta)
    544     ENDIF
    545 ! Repartition entre 2 etats de guidage
     534    !-----------------------------------------------------------------------
     535    ! Interpolation et conversion des champs de guidage
     536    !-----------------------------------------------------------------------
     537    IF (MOD(itau, iguide_int)==0) THEN
     538      CALL guide_interp(ps, teta)
     539    ENDIF
     540    ! Repartition entre 2 etats de guidage
    546541    IF (iguide_read/=0) THEN
    547         tau=reste
     542      tau = reste
    548543    ELSE
    549         tau=1.
    550     ENDIF
    551 
    552 !    CALL WriteField_u('ucov_guide',ucov)
    553 !    CALL WriteField_v('vcov_guide',vcov)
    554 !    CALL WriteField_u('teta_guide',teta)
    555 !    CALL WriteField_u('masse_guide',masse)
    556    
    557    
    558 !-----------------------------------------------------------------------
    559 !   Ajout des champs de guidage
    560 !-----------------------------------------------------------------------
    561 ! Sauvegarde du guidage?
    562     f_out=((MOD(itau,iguide_sav)==0).AND.guide_sav)
     544      tau = 1.
     545    ENDIF
     546
     547    !    CALL WriteField_u('ucov_guide',ucov)
     548    !    CALL WriteField_v('vcov_guide',vcov)
     549    !    CALL WriteField_u('teta_guide',teta)
     550    !    CALL WriteField_u('masse_guide',masse)
     551
     552
     553    !-----------------------------------------------------------------------
     554    !   Ajout des champs de guidage
     555    !-----------------------------------------------------------------------
     556    ! Sauvegarde du guidage?
     557    f_out = ((MOD(itau, iguide_sav)==0).AND.guide_sav)
    563558    IF (f_out) THEN
    564559
    565 !$OMP BARRIER
    566       CALL pression_loc(ijnb_u,ap,bp,ps,p)
    567 
    568 !$OMP BARRIER
    569       if (pressure_exner) THEN
    570       CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk)
     560      !$OMP BARRIER
     561      CALL pression_loc(ijnb_u, ap, bp, ps, p)
     562
     563      !$OMP BARRIER
     564      IF (pressure_exner) THEN
     565        CALL exner_hyb_loc(ijnb_u, ps, p, pks, pk)
    571566      else
    572         CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk )
    573       endif
    574 
    575 !$OMP BARRIER
    576 
    577         unskap=1./kappa
    578 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     567        CALL exner_milieu_loc(ijnb_u, ps, p, pks, pk)
     568      endif
     569
     570      !$OMP BARRIER
     571
     572      unskap = 1. / kappa
     573      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     574      DO l = 1, llm
     575        DO j = jjbu, jjeu
     576          DO i = 1, iip1
     577            p(i + (j - 1) * iip1, l) = preff * (pk(i, j, l) / cpp) ** unskap
     578          ENDDO
     579        ENDDO
     580      ENDDO
     581
     582      CALL guide_out("SP", jjp1, llm, p(ijb_u:ije_u, 1:llm), 1.)
     583    ENDIF
     584
     585    IF (guide_u) THEN
     586      IF (guide_add) THEN
     587        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    579588        DO l = 1, llm
    580             DO j=jjbu,jjeu
    581                 DO i =1, iip1
    582                     p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap
    583                 ENDDO
    584             ENDDO
    585         ENDDO
    586 
    587         CALL guide_out("SP",jjp1,llm,p(ijb_u:ije_u,1:llm),1.)
    588     ENDIF
    589    
    590     if (guide_u) THEN
    591         if (guide_add) THEN
    592 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    593           DO l=1,llm
    594            f_addu(ijbu:ijeu,l)=(1.-tau)*ugui1(ijbu:ijeu,l)+tau*ugui2(ijbu:ijeu,l)
    595           ENDDO
    596         else
    597 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    598           DO l=1,llm
    599            f_addu(ijbu:ijeu,l)=(1.-tau)*ugui1(ijbu:ijeu,l)+tau*ugui2(ijbu:ijeu,l)-ucov(ijbu:ijeu,l)
    600           ENDDO
    601         endif
    602    
    603 !        CALL WriteField_u('f_addu',f_addu)
    604 
    605         if (guide_zon) CALL guide_zonave_u(1,llm,f_addu)
    606         CALL guide_addfield_u(llm,f_addu,alpha_u)
    607         IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:),factt)
    608         IF (f_out) CALL guide_out("u",jjp1,llm,ucov(ijb_u:ije_u,:),factt)
    609         IF (f_out) THEN
    610          ! Ehouarn: fill the gaps adequately...
    611          IF (ijbu>ijb_u) f_addu(ijb_u:ijbu-1,:)=0
    612          IF (ijeu<ije_u) f_addu(ijeu+1:ije_u,:)=0
    613          CALL guide_out("ucov",jjp1,llm,f_addu(ijb_u:ije_u,:)/factt,factt)
    614         ENDIF
    615 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    616         DO l=1,llm
    617           ucov(ijbu:ijeu,l)=ucov(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
    618         ENDDO
     589          f_addu(ijbu:ijeu, l) = (1. - tau) * ugui1(ijbu:ijeu, l) + tau * ugui2(ijbu:ijeu, l)
     590        ENDDO
     591      else
     592        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     593        DO l = 1, llm
     594          f_addu(ijbu:ijeu, l) = (1. - tau) * ugui1(ijbu:ijeu, l) + tau * ugui2(ijbu:ijeu, l) - ucov(ijbu:ijeu, l)
     595        ENDDO
     596      endif
     597
     598      !        CALL WriteField_u('f_addu',f_addu)
     599
     600      IF (guide_zon) CALL guide_zonave_u(1, llm, f_addu)
     601      CALL guide_addfield_u(llm, f_addu, alpha_u)
     602      IF (f_out) CALL guide_out("ua", jjp1, llm, (1. - tau) * ugui1(ijb_u:ije_u, :) + tau * ugui2(ijb_u:ije_u, :), factt)
     603      IF (f_out) CALL guide_out("u", jjp1, llm, ucov(ijb_u:ije_u, :), factt)
     604      IF (f_out) THEN
     605        ! Ehouarn: fill the gaps adequately...
     606        IF (ijbu>ijb_u) f_addu(ijb_u:ijbu - 1, :) = 0
     607        IF (ijeu<ije_u) f_addu(ijeu + 1:ije_u, :) = 0
     608        CALL guide_out("ucov", jjp1, llm, f_addu(ijb_u:ije_u, :) / factt, factt)
     609      ENDIF
     610      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     611      DO l = 1, llm
     612        ucov(ijbu:ijeu, l) = ucov(ijbu:ijeu, l) + f_addu(ijbu:ijeu, l)
     613      ENDDO
    619614
    620615    endif
    621616
    622     if (guide_T) THEN
    623         if (guide_add) THEN
    624 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    625           DO l=1,llm
    626             f_addu(ijbu:ijeu,l)=(1.-tau)*tgui1(ijbu:ijeu,l)+tau*tgui2(ijbu:ijeu,l)
    627           ENDDO
    628         else
    629 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    630           DO l=1,llm
    631            f_addu(ijbu:ijeu,l)=(1.-tau)*tgui1(ijbu:ijeu,l)+tau*tgui2(ijbu:ijeu,l)-teta(ijbu:ijeu,l)
    632           ENDDO
    633         endif
    634         if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
    635         CALL guide_addfield_u(llm,f_addu,alpha_T)
    636         IF (f_out) CALL guide_out("teta",jjp1,llm,f_addu(:,:)/factt,factt)
    637 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    638         DO l=1,llm
    639           teta(ijbu:ijeu,l)=teta(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
    640         ENDDO
     617    IF (guide_T) THEN
     618      IF (guide_add) THEN
     619        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     620        DO l = 1, llm
     621          f_addu(ijbu:ijeu, l) = (1. - tau) * tgui1(ijbu:ijeu, l) + tau * tgui2(ijbu:ijeu, l)
     622        ENDDO
     623      else
     624        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     625        DO l = 1, llm
     626          f_addu(ijbu:ijeu, l) = (1. - tau) * tgui1(ijbu:ijeu, l) + tau * tgui2(ijbu:ijeu, l) - teta(ijbu:ijeu, l)
     627        ENDDO
     628      endif
     629      IF (guide_zon) CALL guide_zonave_u(2, llm, f_addu)
     630      CALL guide_addfield_u(llm, f_addu, alpha_T)
     631      IF (f_out) CALL guide_out("teta", jjp1, llm, f_addu(:, :) / factt, factt)
     632      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     633      DO l = 1, llm
     634        teta(ijbu:ijeu, l) = teta(ijbu:ijeu, l) + f_addu(ijbu:ijeu, l)
     635      ENDDO
    641636    endif
    642637
    643     if (guide_P) THEN
    644         if (guide_add) THEN
    645 !$OMP MASTER
    646             f_addu(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)
    647 !$OMP END MASTER
    648 !$OMP BARRIER
    649         else
    650 !$OMP MASTER
    651             f_addu(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)-ps(ijbu:ijeu)
    652 !$OMP END MASTER
    653 !$OMP BARRIER
    654         endif
    655         if (guide_zon) CALL guide_zonave_u(2,1,f_addu(ijb_u:ije_u,1))
    656         CALL guide_addfield_u(1,f_addu(ijb_u:ije_u,1),alpha_P)
    657 !       IF (f_out) CALL guide_out("ps",jjp1,1,f_addu(ijb_u:ije_u,1)/factt,factt)
    658 !$OMP MASTER
    659         ps(ijbu:ijeu)=ps(ijbu:ijeu)+f_addu(ijbu:ijeu,1)
    660 !$OMP END MASTER
    661 !$OMP BARRIER
    662         CALL pression_loc(ijnb_u,ap,bp,ps,p)
    663         CALL massdair_loc(p,masse)
    664 !$OMP BARRIER
     638    IF (guide_P) THEN
     639      IF (guide_add) THEN
     640        !$OMP MASTER
     641        f_addu(ijbu:ijeu, 1) = (1. - tau) * psgui1(ijbu:ijeu) + tau * psgui2(ijbu:ijeu)
     642        !$OMP END MASTER
     643        !$OMP BARRIER
     644      else
     645        !$OMP MASTER
     646        f_addu(ijbu:ijeu, 1) = (1. - tau) * psgui1(ijbu:ijeu) + tau * psgui2(ijbu:ijeu) - ps(ijbu:ijeu)
     647        !$OMP END MASTER
     648        !$OMP BARRIER
     649      endif
     650      IF (guide_zon) CALL guide_zonave_u(2, 1, f_addu(ijb_u:ije_u, 1))
     651      CALL guide_addfield_u(1, f_addu(ijb_u:ije_u, 1), alpha_P)
     652      !       IF (f_out) CALL guide_out("ps",jjp1,1,f_addu(ijb_u:ije_u,1)/factt,factt)
     653      !$OMP MASTER
     654      ps(ijbu:ijeu) = ps(ijbu:ijeu) + f_addu(ijbu:ijeu, 1)
     655      !$OMP END MASTER
     656      !$OMP BARRIER
     657      CALL pression_loc(ijnb_u, ap, bp, ps, p)
     658      CALL massdair_loc(p, masse)
     659      !$OMP BARRIER
    665660    endif
    666661
    667     if (guide_Q) THEN
    668         if (guide_add) THEN
    669 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    670           DO l=1,llm
    671             f_addu(ijbu:ijeu,l)=(1.-tau)*qgui1(ijbu:ijeu,l)+tau*qgui2(ijbu:ijeu,l)
    672           ENDDO
    673         else
    674 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    675           DO l=1,llm
    676             f_addu(ijbu:ijeu,l)=(1.-tau)*qgui1(ijbu:ijeu,l)+tau*qgui2(ijbu:ijeu,l)-q(ijbu:ijeu,l)
    677           ENDDO
    678         endif
    679         if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
    680         CALL guide_addfield_u(llm,f_addu,alpha_Q)
    681         IF (f_out) CALL guide_out("q",jjp1,llm,f_addu(:,:)/factt,factt)
    682 
    683 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    684         DO l=1,llm
    685           q(ijbu:ijeu,l)=q(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
    686         ENDDO
     662    IF (guide_Q) THEN
     663      IF (guide_add) THEN
     664        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     665        DO l = 1, llm
     666          f_addu(ijbu:ijeu, l) = (1. - tau) * qgui1(ijbu:ijeu, l) + tau * qgui2(ijbu:ijeu, l)
     667        ENDDO
     668      else
     669        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     670        DO l = 1, llm
     671          f_addu(ijbu:ijeu, l) = (1. - tau) * qgui1(ijbu:ijeu, l) + tau * qgui2(ijbu:ijeu, l) - q(ijbu:ijeu, l)
     672        ENDDO
     673      endif
     674      IF (guide_zon) CALL guide_zonave_u(2, llm, f_addu)
     675      CALL guide_addfield_u(llm, f_addu, alpha_Q)
     676      IF (f_out) CALL guide_out("q", jjp1, llm, f_addu(:, :) / factt, factt)
     677
     678      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     679      DO l = 1, llm
     680        q(ijbu:ijeu, l) = q(ijbu:ijeu, l) + f_addu(ijbu:ijeu, l)
     681      ENDDO
    687682    endif
    688683
    689     if (guide_v) THEN
    690         if (guide_add) THEN
    691 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    692           DO l=1,llm
    693              f_addv(ijbv:ijev,l)=(1.-tau)*vgui1(ijbv:ijev,l)+tau*vgui2(ijbv:ijev,l)
    694           ENDDO
    695 
    696         else
    697 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    698           DO l=1,llm
    699             f_addv(ijbv:ijev,l)=(1.-tau)*vgui1(ijbv:ijev,l)+tau*vgui2(ijbv:ijev,l)-vcov(ijbv:ijev,l)
    700           ENDDO
    701 
    702         endif
    703    
    704         if (guide_zon) CALL guide_zonave_v(2,jjm,llm,f_addv(ijb_v:ije_v,:))
    705        
    706         CALL guide_addfield_v(llm,f_addv(ijb_v:ije_v,:),alpha_v)
    707         IF (f_out) CALL guide_out("v",jjm,llm,vcov(ijb_v:ije_v,:),factt)
    708         IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:),factt)
    709         IF (f_out) THEN
    710           ! Ehouarn: Fill in the gaps adequately
    711           IF (ijbv>ijb_v) f_addv(ijb_v:ijbv-1,:)=0
    712           IF (ijev<ije_v) f_addv(ijev+1:ije_v,:)=0
    713           CALL guide_out("vcov",jjm,llm,f_addv(ijb_v:ije_v,:)/factt,factt)
    714         ENDIF
    715 
    716 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    717         DO l=1,llm
    718           vcov(ijbv:ijev,l)=vcov(ijbv:ijev,l)+f_addv(ijbv:ijev,l)
    719         ENDDO
     684    IF (guide_v) THEN
     685      IF (guide_add) THEN
     686        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     687        DO l = 1, llm
     688          f_addv(ijbv:ijev, l) = (1. - tau) * vgui1(ijbv:ijev, l) + tau * vgui2(ijbv:ijev, l)
     689        ENDDO
     690
     691      else
     692        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     693        DO l = 1, llm
     694          f_addv(ijbv:ijev, l) = (1. - tau) * vgui1(ijbv:ijev, l) + tau * vgui2(ijbv:ijev, l) - vcov(ijbv:ijev, l)
     695        ENDDO
     696
     697      endif
     698
     699      IF (guide_zon) CALL guide_zonave_v(2, jjm, llm, f_addv(ijb_v:ije_v, :))
     700
     701      CALL guide_addfield_v(llm, f_addv(ijb_v:ije_v, :), alpha_v)
     702      IF (f_out) CALL guide_out("v", jjm, llm, vcov(ijb_v:ije_v, :), factt)
     703      IF (f_out) CALL guide_out("va", jjm, llm, (1. - tau) * vgui1(ijb_v:ije_v, :) + tau * vgui2(ijb_v:ije_v, :), factt)
     704      IF (f_out) THEN
     705        ! Ehouarn: Fill in the gaps adequately
     706        IF (ijbv>ijb_v) f_addv(ijb_v:ijbv - 1, :) = 0
     707        IF (ijev<ije_v) f_addv(ijev + 1:ije_v, :) = 0
     708        CALL guide_out("vcov", jjm, llm, f_addv(ijb_v:ije_v, :) / factt, factt)
     709      ENDIF
     710
     711      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     712      DO l = 1, llm
     713        vcov(ijbv:ijev, l) = vcov(ijbv:ijev, l) + f_addv(ijbv:ijev, l)
     714      ENDDO
    720715    endif
    721716
    … …  
    723718
    724719
    725   SUBROUTINE guide_addfield_u(vsize,field,alpha)
    726 ! field1=a*field1+alpha*field2
     720  SUBROUTINE guide_addfield_u(vsize, field, alpha)
     721    ! field1=a*field1+alpha*field2
    727722
    728723    IMPLICIT NONE
    … …  
    731726
    732727    ! input variables
    733     INTEGER,                      INTENT(IN)    :: vsize
    734     REAL, DIMENSION(ijb_u:ije_u),       INTENT(IN)    :: alpha
    735     REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
     728    INTEGER, INTENT(IN) :: vsize
     729    REAL, DIMENSION(ijb_u:ije_u), INTENT(IN) :: alpha
     730    REAL, DIMENSION(ijb_u:ije_u, vsize), INTENT(INOUT) :: field
    736731
    737732    ! Local variables
    738733    INTEGER :: l
    739734
    740 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    741     DO l=1,vsize
    742       field(ijbu:ijeu,l)=alpha(ijbu:ijeu)*field(ijbu:ijeu,l)*alpha_pcor(l)
     735    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     736    DO l = 1, vsize
     737      field(ijbu:ijeu, l) = alpha(ijbu:ijeu) * field(ijbu:ijeu, l) * alpha_pcor(l)
    743738    ENDDO
    744739
    … …  
    746741
    747742
    748   SUBROUTINE guide_addfield_v(vsize,field,alpha)
    749 ! field1=a*field1+alpha*field2
     743  SUBROUTINE guide_addfield_v(vsize, field, alpha)
     744    ! field1=a*field1+alpha*field2
    750745
    751746    IMPLICIT NONE
    … …  
    754749
    755750    ! input variables
    756     INTEGER,                      INTENT(IN)    :: vsize
    757     REAL, DIMENSION(ijb_v:ije_v),       INTENT(IN)    :: alpha
    758     REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
     751    INTEGER, INTENT(IN) :: vsize
     752    REAL, DIMENSION(ijb_v:ije_v), INTENT(IN) :: alpha
     753    REAL, DIMENSION(ijb_v:ije_v, vsize), INTENT(INOUT) :: field
    759754
    760755    ! Local variables
    761756    INTEGER :: l
    762757
    763 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    764     DO l=1,vsize
    765       field(ijbv:ijev,l)=alpha(ijbv:ijev)*field(ijbv:ijev,l)*alpha_pcor(l)
     758    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     759    DO l = 1, vsize
     760      field(ijbv:ijev, l) = alpha(ijbv:ijev) * field(ijbv:ijev, l) * alpha_pcor(l)
    766761    ENDDO
    767762
    768763  END SUBROUTINE guide_addfield_v
    769  
    770 !=======================================================================
    771 
    772   SUBROUTINE guide_zonave_u(typ,vsize,field)
     764
     765  !=======================================================================
     766
     767  SUBROUTINE guide_zonave_u(typ, vsize, field)
    773768
    774769    USE comconst_mod, ONLY: pi
    775    
     770
    776771    IMPLICIT NONE
    777772
    … …  
    779774    INCLUDE "paramet.h"
    780775    INCLUDE "comgeom.h"
    781    
     776
    782777    ! input/output variables
    783     INTEGER,                           INTENT(IN)    :: typ
    784     INTEGER,                           INTENT(IN)    :: vsize
    785     REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
     778    INTEGER, INTENT(IN) :: typ
     779    INTEGER, INTENT(IN) :: vsize
     780    REAL, DIMENSION(ijb_u:ije_u, vsize), INTENT(INOUT) :: field
    786781
    787782    ! Local variables
    788     LOGICAL, SAVE                :: first=.TRUE.
    789 !$OMP THREADPRIVATE(first)
     783    LOGICAL, SAVE :: first = .TRUE.
     784    !$OMP THREADPRIVATE(first)
    790785
    791786    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
    792 !$OMP THREADPRIVATE(imin,imax)   
    793     INTEGER                      :: i,j,l,ij
    794     REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
    795     REAL, DIMENSION (jjb_u:jje_u,vsize):: fieldm     ! zon-averaged field
     787    !$OMP THREADPRIVATE(imin,imax)
     788    INTEGER :: i, j, l, ij
     789    REAL, DIMENSION (iip1) :: lond       ! longitude in Deg.
     790    REAL, DIMENSION (jjb_u:jje_u, vsize) :: fieldm     ! zon-averaged field
    796791
    797792    IF (first) THEN
    798         first=.FALSE.
    799 !Compute domain for averaging
    800         lond=rlonu*180./pi
    801         imin(1)=1;imax(1)=iip1;
    802         imin(2)=1;imax(2)=iip1;
    803         IF (guide_reg) THEN
    804             DO i=1,iim
    805                 IF (lond(i)<lon_min_g) imin(1)=i
    806                 IF (lond(i)<=lon_max_g) imax(1)=i
    807             ENDDO
    808             lond=rlonv*180./pi
    809             DO i=1,iim
    810                 IF (lond(i)<lon_min_g) imin(2)=i
    811                 IF (lond(i)<=lon_max_g) imax(2)=i
    812             ENDDO
    813         ENDIF
    814     ENDIF
    815 
    816    
    817 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    818       DO l=1,vsize
    819         fieldm(:,l)=0.
     793      first = .FALSE.
     794      !Compute domain for averaging
     795      lond = rlonu * 180. / pi
     796      imin(1) = 1;imax(1) = iip1;
     797      imin(2) = 1;imax(2) = iip1;
     798      IF (guide_reg) THEN
     799        DO i = 1, iim
     800          IF (lond(i)<lon_min_g) imin(1) = i
     801          IF (lond(i)<=lon_max_g) imax(1) = i
     802        ENDDO
     803        lond = rlonv * 180. / pi
     804        DO i = 1, iim
     805          IF (lond(i)<lon_min_g) imin(2) = i
     806          IF (lond(i)<=lon_max_g) imax(2) = i
     807        ENDDO
     808      ENDIF
     809    ENDIF
     810
     811
     812    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     813    DO l = 1, vsize
     814      fieldm(:, l) = 0.
    820815      ! Compute zonal average
    821816
    822 !correction bug ici
    823 ! ---> a verifier
    824 ! ym         DO j=jjbv,jjev
    825          DO j=jjbu,jjeu
    826               DO i=imin(typ),imax(typ)
    827                   ij=(j-1)*iip1+i
    828                   fieldm(j,l)=fieldm(j,l)+field(ij,l)
    829               ENDDO
    830           ENDDO
    831           fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
    832     ! Compute forcing
    833           DO j=jjbu,jjeu
    834               DO i=1,iip1
    835                   ij=(j-1)*iip1+i
    836                   field(ij,l)=fieldm(j,l)
    837               ENDDO
    838           ENDDO
     817      !correction bug ici
     818      ! ---> a verifier
     819      ! ym         DO j=jjbv,jjev
     820      DO j = jjbu, jjeu
     821        DO i = imin(typ), imax(typ)
     822          ij = (j - 1) * iip1 + i
     823          fieldm(j, l) = fieldm(j, l) + field(ij, l)
     824        ENDDO
    839825      ENDDO
     826      fieldm(:, l) = fieldm(:, l) / REAL(imax(typ) - imin(typ) + 1)
     827      ! Compute forcing
     828      DO j = jjbu, jjeu
     829        DO i = 1, iip1
     830          ij = (j - 1) * iip1 + i
     831          field(ij, l) = fieldm(j, l)
     832        ENDDO
     833      ENDDO
     834    ENDDO
    840835
    841836  END SUBROUTINE guide_zonave_u
    842837
    843838
    844   SUBROUTINE guide_zonave_v(typ,hsize,vsize,field)
     839  SUBROUTINE guide_zonave_v(typ, hsize, vsize, field)
    845840
    846841    USE comconst_mod, ONLY: pi
    847    
     842
    848843    IMPLICIT NONE
    849844
    … …  
    851846    INCLUDE "paramet.h"
    852847    INCLUDE "comgeom.h"
    853    
     848
    854849    ! input/output variables
    855     INTEGER,                           INTENT(IN)    :: typ
    856     INTEGER,                           INTENT(IN)    :: vsize
    857     INTEGER,                           INTENT(IN)    :: hsize
    858     REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
     850    INTEGER, INTENT(IN) :: typ
     851    INTEGER, INTENT(IN) :: vsize
     852    INTEGER, INTENT(IN) :: hsize
     853    REAL, DIMENSION(ijb_v:ije_v, vsize), INTENT(INOUT) :: field
    859854
    860855    ! Local variables
    861     LOGICAL, SAVE                :: first=.TRUE.
    862 !$OMP THREADPRIVATE(first)
     856    LOGICAL, SAVE :: first = .TRUE.
     857    !$OMP THREADPRIVATE(first)
    863858    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
    864 !$OMP THREADPRIVATE(imin, imax)
    865     INTEGER                      :: i,j,l,ij
    866     REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
    867     REAL, DIMENSION (jjb_v:jjev,vsize):: fieldm     ! zon-averaged field
     859    !$OMP THREADPRIVATE(imin, imax)
     860    INTEGER :: i, j, l, ij
     861    REAL, DIMENSION (iip1) :: lond       ! longitude in Deg.
     862    REAL, DIMENSION (jjb_v:jjev, vsize) :: fieldm     ! zon-averaged field
    868863
    869864    IF (first) THEN
    870         first=.FALSE.
    871 !Compute domain for averaging
    872         lond=rlonu*180./pi
    873         imin(1)=1;imax(1)=iip1;
    874         imin(2)=1;imax(2)=iip1;
    875         IF (guide_reg) THEN
    876             DO i=1,iim
    877                 IF (lond(i)<lon_min_g) imin(1)=i
    878                 IF (lond(i)<=lon_max_g) imax(1)=i
    879             ENDDO
    880             lond=rlonv*180./pi
    881             DO i=1,iim
    882                 IF (lond(i)<lon_min_g) imin(2)=i
    883                 IF (lond(i)<=lon_max_g) imax(2)=i
    884             ENDDO
    885         ENDIF
    886     ENDIF
    887 
    888 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    889       DO l=1,vsize
     865      first = .FALSE.
     866      !Compute domain for averaging
     867      lond = rlonu * 180. / pi
     868      imin(1) = 1;imax(1) = iip1;
     869      imin(2) = 1;imax(2) = iip1;
     870      IF (guide_reg) THEN
     871        DO i = 1, iim
     872          IF (lond(i)<lon_min_g) imin(1) = i
     873          IF (lond(i)<=lon_max_g) imax(1) = i
     874        ENDDO
     875        lond = rlonv * 180. / pi
     876        DO i = 1, iim
     877          IF (lond(i)<lon_min_g) imin(2) = i
     878          IF (lond(i)<=lon_max_g) imax(2) = i
     879        ENDDO
     880      ENDIF
     881    ENDIF
     882
     883    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     884    DO l = 1, vsize
    890885      ! Compute zonal average
    891           fieldm(:,l)=0.
    892           DO j=jjbv,jjev
    893               DO i=imin(typ),imax(typ)
    894                   ij=(j-1)*iip1+i
    895                   fieldm(j,l)=fieldm(j,l)+field(ij,l)
    896               ENDDO
    897           ENDDO
    898           fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
    899     ! Compute forcing
    900           DO j=jjbv,jjev
    901               DO i=1,iip1
    902                   ij=(j-1)*iip1+i
    903                   field(ij,l)=fieldm(j,l)
    904               ENDDO
    905           ENDDO
     886      fieldm(:, l) = 0.
     887      DO j = jjbv, jjev
     888        DO i = imin(typ), imax(typ)
     889          ij = (j - 1) * iip1 + i
     890          fieldm(j, l) = fieldm(j, l) + field(ij, l)
     891        ENDDO
    906892      ENDDO
    907 
     893      fieldm(:, l) = fieldm(:, l) / REAL(imax(typ) - imin(typ) + 1)
     894      ! Compute forcing
     895      DO j = jjbv, jjev
     896        DO i = 1, iip1
     897          ij = (j - 1) * iip1 + i
     898          field(ij, l) = fieldm(j, l)
     899        ENDDO
     900      ENDDO
     901    ENDDO
    908902
    909903  END SUBROUTINE guide_zonave_v
    910  
    911 !=======================================================================
    912   SUBROUTINE guide_interp(psi,teta)
    913     use exner_hyb_loc_m, ONLY: exner_hyb_loc
    914     use exner_milieu_loc_m, ONLY: exner_milieu_loc
    915   USE parallel_lmdz
    916   USE mod_hallo
    917   USE Bands
    918   USE comconst_mod, ONLY: cpp, kappa
    919   USE comvert_mod, ONLY: preff, pressure_exner, bp, ap, disvert_type
    920   IMPLICIT NONE
    921 
    922   include "dimensions.h"
    923   include "paramet.h"
    924   include "comgeom2.h"
    925 
    926   REAL, DIMENSION (iip1,jjb_u:jje_u),     INTENT(IN) :: psi ! Psol gcm
    927   REAL, DIMENSION (iip1,jjb_u:jje_u,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
    928 
    929   LOGICAL, SAVE                      :: first=.TRUE.
    930 !$OMP THREADPRIVATE(first)
    931   ! Variables pour niveaux pression:
    932   REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: plnc1,plnc2 !niveaux pression guidage
    933   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: plunc,plsnc !niveaux pression modele
    934   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: plvnc       !niveaux pression modele
    935   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)  :: p           ! pression intercouches
    936   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pls, pext   ! var intermediaire
    937   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pbarx
    938   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: pbary
    939   ! Variables pour fonction Exner (P milieu couche)
    940   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pk
    941   REAL ,ALLOCATABLE, SAVE, DIMENSION (:,:)        :: pks   
    942   REAL                               :: unskap
    943   ! Pression de vapeur saturante
    944   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:)      :: qsat
    945   !Variables intermediaires interpolation
    946   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: zu1,zu2
    947   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: zv1,zv2
    948  
    949   INTEGER                            :: i,j,l,ij
    950   CHARACTER(LEN=20),PARAMETER :: modname="guide_interp"
    951   TYPE(Request),SAVE :: Req 
    952 !$OMP THREADPRIVATE(Req)
    953    
    954     if (is_master) WRITE(*,*)trim(modname)//': interpolate nudging variables'
    955 ! -----------------------------------------------------------------
    956 ! Calcul des niveaux de pression champs guidage (pour T et Q)
    957 ! -----------------------------------------------------------------
    958     IF (first) THEN
    959 !$OMP MASTER
    960       ALLOCATE(plnc1(iip1,jjb_u:jje_u,nlevnc) )   
    961       ALLOCATE(plnc2(iip1,jjb_u:jje_u,nlevnc) )   
    962       ALLOCATE(plunc(iip1,jjb_u:jje_u,llm) )   
    963       ALLOCATE(plsnc(iip1,jjb_u:jje_u,llm) )   
    964       ALLOCATE(plvnc(iip1,jjb_v:jje_v,llm) )   
    965       ALLOCATE(p(iip1,jjb_u:jje_u,llmp1) )   
    966       ALLOCATE(pls(iip1,jjb_u:jje_u,llm) )   
    967       ALLOCATE(pext(iip1,jjb_u:jje_u,llm) )   
    968       ALLOCATE(pbarx(iip1,jjb_u:jje_u,llm) )   
    969       ALLOCATE(pbary(iip1,jjb_v:jje_v,llm) )   
    970       ALLOCATE(pk(iip1,jjb_u:jje_u,llm) )   
    971       ALLOCATE(pks (iip1,jjb_u:jje_u) )   
    972       ALLOCATE(qsat(ijb_u:ije_u,llm) )   
    973       ALLOCATE(zu1(iip1,jjb_u:jje_u,llm) )   
    974       ALLOCATE(zu2(iip1,jjb_u:jje_u,llm) )   
    975       ALLOCATE(zv1(iip1,jjb_v:jje_v,llm) )   
    976       ALLOCATE(zv2(iip1,jjb_v:jje_v,llm) )
    977 !$OMP END MASTER
    978 !$OMP BARRIER
    979     ENDIF       
    980 
    981    
    982    
    983    
    984     IF (guide_plevs==0) THEN
    985 !$OMP DO
    986         DO l=1,nlevnc
    987             DO j=jjbu,jjeu
    988                 DO i=1,iip1
    989                     plnc2(i,j,l)=apnc(l)
    990                     plnc1(i,j,l)=apnc(l)
    991                ENDDO
    992             ENDDO
    993         ENDDO
    994     ENDIF   
    995 
    996     if (first) THEN
    997         first=.FALSE.
    998 !$OMP MASTER
    999         WRITE(*,*)trim(modname)//' : check vertical level order'
    1000         WRITE(*,*)trim(modname)//' LMDZ :'
    1001         do l=1,llm
    1002           WRITE(*,*)trim(modname)//' PL(',l,')=',(ap(l)+ap(l+1))/2. &
    1003                   +psi(1,jjeu)*(bp(l)+bp(l+1))/2.
    1004         enddo
    1005         WRITE(*,*)trim(modname)//' nudging file :'
    1006         SELECT CASE (guide_plevs)
    1007         CASE (0)
    1008             do l=1,nlevnc
    1009               WRITE(*,*)trim(modname)//' PL(',l,')=',plnc2(1,jjbu,l)
    1010             enddo
    1011         CASE (1)
    1012             DO l=1,nlevnc
    1013               WRITE(*,*)trim(modname)//' PL(',l,')=',&
    1014                         apnc(l)+bpnc(l)*psnat2(1,jjbu)
    1015             ENDDO
    1016         CASE (2)
    1017             do l=1,nlevnc
    1018               WRITE(*,*)trim(modname)//' PL(',l,')=',pnat2(1,jjbu,l)
    1019             enddo
    1020         END SELECT
    1021         WRITE(*,*)trim(modname)//' invert ordering: invert_p=',invert_p
    1022         if (guide_u) THEN
    1023             do l=1,nlevnc
    1024               WRITE(*,*)trim(modname)//' U(',l,')=',unat2(1,jjbu,l)
    1025             enddo
    1026         endif
    1027         if (guide_T) THEN
    1028             do l=1,nlevnc
    1029               WRITE(*,*)trim(modname)//' T(',l,')=',tnat2(1,jjbu,l)
    1030             enddo
    1031         endif
    1032 !$OMP END MASTER
    1033     endif ! of if (first)
    1034 
    1035     if (guide_plevs /= 1 .or. guide_t .and. .not. guide_teta &
    1036          .or. guide_q .and. guide_hr) THEN
    1037        CALL pression_loc( ijnb_u, ap, bp, psi, p )
    1038        if (disvert_type==1) THEN
    1039           CALL exner_hyb_loc(ijnb_u,psi,p,pks,pk)
    1040        else ! we assume that we are in the disvert_type==2 case
    1041           CALL exner_milieu_loc(ijnb_u,psi,p,pks,pk)
    1042        endif
    1043     end if
    1044 
    1045 ! -----------------------------------------------------------------
    1046 ! Calcul niveaux pression modele
    1047 ! -----------------------------------------------------------------
    1048 
    1049 !    ....  Calcul de pls , pression au milieu des couches ,en Pascals
    1050     IF (guide_plevs==1) THEN
    1051 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1052         DO l=1,llm
    1053             DO j=jjbu,jjeu
    1054                 DO i =1, iip1
    1055                     pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2.
    1056                 ENDDO
    1057             ENDDO
    1058         ENDDO
    1059     ELSE
    1060         unskap=1./kappa
    1061 !$OMP BARRIER
    1062 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1063    DO l = 1, llm
    1064        DO j=jjbu,jjeu
    1065            DO i =1, iip1
    1066                pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
    1067            ENDDO
    1068        ENDDO
    1069    ENDDO
    1070     ENDIF
    1071 
    1072 !   calcul des pressions pour les grilles u et v
    1073 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1074     do l=1,llm
    1075         do j=jjbu,jjeu
    1076             do i=1,iip1
    1077                 pext(i,j,l)=pls(i,j,l)*aire(i,j)
    1078             enddo
    1079         enddo
    1080     enddo
    1081 
    1082      CALL Register_Hallo_u(pext,llm,1,2,2,1,Req)
    1083      CALL SendRequest(Req)
    1084 !$OMP BARRIER
    1085      CALL WaitRequest(Req)
    1086 !$OMP BARRIER
    1087 
    1088     CALL massbar_loc(pext, pbarx, pbary )
    1089 !$OMP BARRIER
    1090 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1091     do l=1,llm
    1092         do j=jjbu,jjeu
    1093             do i=1,iip1
    1094                 plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
    1095                 plsnc(i,j,l)=pls(i,j,l)
    1096             enddo
    1097         enddo
    1098     enddo
    1099 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1100     do l=1,llm
    1101         do j=jjbv,jjev
    1102             do i=1,iip1
    1103                 plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
    1104             enddo
    1105         enddo
    1106     enddo
    1107 
    1108 ! -----------------------------------------------------------------
    1109 ! Interpolation verticale champs guidage sur niveaux modele
    1110 ! Conversion en variables gcm (ucov, vcov...)
    1111 ! -----------------------------------------------------------------
    1112     if (guide_P) THEN
    1113 !$OMP MASTER
    1114         do j=jjbu,jjeu
    1115             do i=1,iim
    1116                 ij=(j-1)*iip1+i
    1117                 psgui1(ij)=psnat1(i,j)
    1118                 psgui2(ij)=psnat2(i,j)
    1119             enddo
    1120             psgui1(iip1*j)=psnat1(1,j)
    1121             psgui2(iip1*j)=psnat2(1,j)
    1122         enddo
    1123 !$OMP END MASTER
    1124 !$OMP BARRIER
    1125     endif
    1126 
    1127     IF (guide_T) THEN
    1128         ! Calcul des nouvelles valeurs des niveaux de pression du guidage
    1129         IF (guide_plevs==1) THEN
    1130 !$OMP DO
    1131             DO l=1,nlevnc
    1132                 DO j=jjbu,jjeu
    1133                     DO i=1,iip1
    1134                         plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
    1135                         plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
    1136                     ENDDO
    1137                 ENDDO
    1138             ENDDO
    1139         ELSE IF (guide_plevs==2) THEN
    1140 !$OMP DO
    1141             DO l=1,nlevnc
    1142                 DO j=jjbu,jjeu
    1143                     DO i=1,iip1
    1144                         plnc2(i,j,l)=pnat2(i,j,l)
    1145                         plnc1(i,j,l)=pnat1(i,j,l)
    1146                     ENDDO
    1147                 ENDDO
    1148             ENDDO
    1149         ENDIF
    1150 
    1151         ! Interpolation verticale
    1152 !$OMP MASTER
    1153         CALL pres2lev(tnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,           &
    1154                     plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
    1155         CALL pres2lev(tnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,           &
    1156                     plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
    1157 !$OMP END MASTER
    1158 !$OMP BARRIER
    1159         ! Conversion en variables GCM
    1160 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1161         do l=1,llm
    1162             do j=jjbu,jjeu
    1163                 IF (guide_teta) THEN
    1164                     do i=1,iim
    1165                         ij=(j-1)*iip1+i
    1166                         tgui1(ij,l)=zu1(i,j,l)
    1167                         tgui2(ij,l)=zu2(i,j,l)
    1168                     enddo
    1169                 ELSE
    1170                     do i=1,iim
    1171                         ij=(j-1)*iip1+i
    1172                         tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
    1173                         tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
    1174                     enddo
    1175                 ENDIF
    1176                 tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)   
    1177                 tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)   
    1178             enddo
    1179             if (pole_nord) THEN
    1180               do i=1,iip1
    1181                 tgui1(i,l)=tgui1(1,l)
    1182                 tgui2(i,l)=tgui2(1,l)
    1183               enddo
    1184             endif
    1185             if (pole_sud) THEN
    1186               do i=1,iip1
    1187                 tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l)
    1188                 tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l)
    1189               enddo
    1190            endif
    1191         enddo
    1192     ENDIF
    1193 
    1194     IF (guide_Q) THEN
    1195         ! Calcul des nouvelles valeurs des niveaux de pression du guidage
    1196         IF (guide_plevs==1) THEN
    1197 !$OMP DO
    1198             DO l=1,nlevnc
    1199                 DO j=jjbu,jjeu
    1200                     DO i=1,iip1
    1201                         plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
    1202                         plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
    1203                     ENDDO
    1204                 ENDDO
    1205             ENDDO
    1206         ELSE IF (guide_plevs==2) THEN
    1207 !$OMP DO
    1208             DO l=1,nlevnc
    1209                 DO j=jjbu,jjeu
    1210                     DO i=1,iip1
    1211                         plnc2(i,j,l)=pnat2(i,j,l)
    1212                         plnc1(i,j,l)=pnat1(i,j,l)
    1213                     ENDDO
    1214                 ENDDO
    1215             ENDDO
    1216         ENDIF
    1217 
    1218         ! Interpolation verticale
    1219 !$OMP MASTER
    1220         CALL pres2lev(qnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,             &
    1221                       plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
    1222         CALL pres2lev(qnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,             &
    1223                       plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
    1224 !$OMP END MASTER
    1225 !$OMP BARRIER
    1226 
    1227         ! Conversion en variables GCM
    1228         ! On suppose qu'on a la bonne variable dans le fichier de guidage:
    1229         ! Hum.Rel si guide_hr, Hum.Spec. sinon.
    1230 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1231         do l=1,llm
    1232             do j=jjbu,jjeu
    1233                 do i=1,iim
    1234                     ij=(j-1)*iip1+i
    1235                     qgui1(ij,l)=zu1(i,j,l)
    1236                     qgui2(ij,l)=zu2(i,j,l)
    1237                 enddo
    1238                 qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)   
    1239                 qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)   
    1240             enddo
    1241             if (pole_nord) THEN
    1242               do i=1,iip1
    1243                 qgui1(i,l)=qgui1(1,l)
    1244                 qgui2(i,l)=qgui2(1,l)
    1245               enddo
    1246             endif
    1247             if (pole_sud) THEN
    1248               do i=1,iip1
    1249                 qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l)
    1250                 qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l)
    1251               enddo
    1252             endif
    1253         enddo
    1254         IF (guide_hr) THEN
    1255 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1256           do l=1,llm
    1257             CALL q_sat(iip1*jjnu,teta(:,jjbu:jjeu,l)*pk(:,jjbu:jjeu,l)/cpp,       &
    1258                        plsnc(:,jjbu:jjeu,l),qsat(ijbu:ijeu,l))
    1259             qgui1(ijbu:ijeu,l)=qgui1(ijbu:ijeu,l)*qsat(ijbu:ijeu,l)*0.01 !hum. rel. en %
    1260             qgui2(ijbu:ijeu,l)=qgui2(ijbu:ijeu,l)*qsat(ijbu:ijeu,l)*0.01
    1261           enddo
    1262 
    1263         ENDIF
    1264     ENDIF
    1265 
    1266     IF (guide_u) THEN
    1267         ! Calcul des nouvelles valeurs des niveaux de pression du guidage
    1268         IF (guide_plevs==1) THEN
    1269 !$OMP DO
    1270             DO l=1,nlevnc
    1271                 DO j=jjbu,jjeu
    1272                     DO i=1,iim
    1273                         plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha1p2(i,j) &
    1274              +psnat2(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
    1275                         plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha1p2(i,j) &
    1276              +psnat1(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
    1277                     ENDDO
    1278                     plnc2(iip1,j,l)=plnc2(1,j,l)
    1279                     plnc1(iip1,j,l)=plnc1(1,j,l)
    1280                 ENDDO
    1281             ENDDO
    1282         ELSE IF (guide_plevs==2) THEN
    1283 !$OMP DO
    1284             DO l=1,nlevnc
    1285                 DO j=jjbu,jjeu
    1286                     DO i=1,iim
    1287                         plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha1p2(i,j) &
    1288    +pnat2(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
    1289                         plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha1p2(i,j) &
    1290    +pnat1(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
    1291                     ENDDO
    1292                     plnc2(iip1,j,l)=plnc2(1,j,l)
    1293                     plnc1(iip1,j,l)=plnc1(1,j,l)
    1294                 ENDDO
    1295             ENDDO
    1296         ENDIF
    1297        
    1298         ! Interpolation verticale
    1299 !$OMP MASTER
    1300         CALL pres2lev(unat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,            &
    1301                       plnc1(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
    1302         CALL pres2lev(unat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,            &
    1303                       plnc2(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
    1304 !$OMP END MASTER
    1305 !$OMP BARRIER
    1306 
    1307         ! Conversion en variables GCM
    1308 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1309         do l=1,llm
    1310             do j=jjbu,jjeu
    1311                 do i=1,iim
    1312                     ij=(j-1)*iip1+i
    1313                     ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
    1314                     ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
    1315                 enddo
    1316                 ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)   
    1317                 ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)   
    1318             enddo
    1319             if (pole_nord) THEN
    1320               do i=1,iip1
    1321                 ugui1(i,l)=0.
    1322                 ugui2(i,l)=0.
    1323               enddo
    1324             endif
    1325             if (pole_sud) THEN
    1326               do i=1,iip1
    1327                 ugui1(ip1jm+i,l)=0.
    1328                 ugui2(ip1jm+i,l)=0.
    1329               enddo
    1330             endif
    1331         enddo
    1332     ENDIF
    1333    
    1334     IF (guide_v) THEN
    1335         ! Calcul des nouvelles valeurs des niveaux de pression du guidage
    1336         IF (guide_plevs==1) THEN
    1337          CALL Register_Hallo_u(psnat1,1,1,2,2,1,Req)
    1338          CALL Register_Hallo_u(psnat2,1,1,2,2,1,Req)
    1339          CALL SendRequest(Req)
    1340 !$OMP BARRIER
    1341          CALL WaitRequest(Req)
    1342 !$OMP BARRIER
    1343 !$OMP DO
    1344             DO l=1,nlevnc
    1345                 DO j=jjbv,jjev
    1346                     DO i=1,iip1
    1347                         plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha2p3(i,j) &
    1348              +psnat2(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
    1349                         plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha2p3(i,j) &
    1350              +psnat1(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
    1351                     ENDDO
    1352                 ENDDO
    1353             ENDDO
    1354         ELSE IF (guide_plevs==2) THEN
    1355          CALL Register_Hallo_u(pnat1,llm,1,2,2,1,Req)
    1356          CALL Register_Hallo_u(pnat2,llm,1,2,2,1,Req)
    1357          CALL SendRequest(Req)
    1358 !$OMP BARRIER
    1359          CALL WaitRequest(Req)
    1360 !$OMP BARRIER
    1361 !$OMP DO
    1362             DO l=1,nlevnc
    1363                 DO j=jjbv,jjev
    1364                     DO i=1,iip1
    1365                         plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha2p3(i,j) &
    1366    +pnat2(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
    1367                         plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha2p3(i,j) &
    1368    +pnat1(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
    1369                     ENDDO
    1370                 ENDDO
    1371             ENDDO
    1372         ENDIF
    1373         ! Interpolation verticale
    1374 
    1375 !$OMP MASTER
    1376         CALL pres2lev(vnat1(:,jjbv:jjev,:),zv1(:,jjbv:jjev,:),nlevnc,llm,             &
    1377                       plnc1(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
    1378         CALL pres2lev(vnat2(:,jjbv:jjev,:),zv2(:,jjbv:jjev,:),nlevnc,llm,             &
    1379                       plnc2(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
    1380 !$OMP END MASTER
    1381 !$OMP BARRIER
    1382         ! Conversion en variables GCM
    1383 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1384         do l=1,llm
    1385             do j=jjbv,jjev
    1386                 do i=1,iim
    1387                     ij=(j-1)*iip1+i
    1388                     vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
    1389                     vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
    1390                 enddo
    1391                 vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)   
    1392                 vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)   
    1393             enddo
    1394         enddo
    1395     ENDIF
    1396    
    1397 
    1398   END SUBROUTINE guide_interp
    1399 
    1400 !=======================================================================
    1401   SUBROUTINE tau2alpha(typ,pim,jjb,jje,factt,taumin,taumax,alpha)
    1402 
    1403 ! Calcul des constantes de rappel alpha (=1/tau)
    1404 
    1405     use comconst_mod, ONLY: pi
    1406     use serre_mod, ONLY: clat, clon, grossismx, grossismy
    1407    
     904
     905  !=======================================================================
     906  SUBROUTINE guide_interp(psi, teta)
     907    USE exner_hyb_loc_m, ONLY: exner_hyb_loc
     908    USE exner_milieu_loc_m, ONLY: exner_milieu_loc
     909    USE parallel_lmdz
     910    USE mod_hallo
     911    USE Bands
     912    USE comconst_mod, ONLY: cpp, kappa
     913    USE comvert_mod, ONLY: preff, pressure_exner, bp, ap, disvert_type
     914    USE lmdz_q_sat, ONLY: q_sat
    1408915    IMPLICIT NONE
    1409916
    … …  
    1412919    include "comgeom2.h"
    1413920
    1414 ! input arguments :
     921    REAL, DIMENSION (iip1, jjb_u:jje_u), INTENT(IN) :: psi ! Psol gcm
     922    REAL, DIMENSION (iip1, jjb_u:jje_u, llm), INTENT(IN) :: teta ! Temp. Pot. gcm
     923
     924    LOGICAL, SAVE :: first = .TRUE.
     925    !$OMP THREADPRIVATE(first)
     926    ! Variables pour niveaux pression:
     927    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: plnc1, plnc2 !niveaux pression guidage
     928    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: plunc, plsnc !niveaux pression modele
     929    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: plvnc       !niveaux pression modele
     930    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: p           ! pression intercouches
     931    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: pls, pext   ! var intermediaire
     932    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: pbarx
     933    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: pbary
     934    ! Variables pour fonction Exner (P milieu couche)
     935    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: pk
     936    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: pks
     937    REAL :: unskap
     938    ! Pression de vapeur saturante
     939    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: qsat
     940    !Variables intermediaires interpolation
     941    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: zu1, zu2
     942    REAL, ALLOCATABLE, SAVE, DIMENSION (:, :, :) :: zv1, zv2
     943
     944    INTEGER :: i, j, l, ij
     945    CHARACTER(LEN = 20), PARAMETER :: modname = "guide_interp"
     946    TYPE(Request), SAVE :: Req
     947    !$OMP THREADPRIVATE(Req)
     948
     949    IF (is_master) WRITE(*, *)trim(modname) // ': interpolate nudging variables'
     950    ! -----------------------------------------------------------------
     951    ! Calcul des niveaux de pression champs guidage (pour T et Q)
     952    ! -----------------------------------------------------------------
     953    IF (first) THEN
     954      !$OMP MASTER
     955      ALLOCATE(plnc1(iip1, jjb_u:jje_u, nlevnc))
     956      ALLOCATE(plnc2(iip1, jjb_u:jje_u, nlevnc))
     957      ALLOCATE(plunc(iip1, jjb_u:jje_u, llm))
     958      ALLOCATE(plsnc(iip1, jjb_u:jje_u, llm))
     959      ALLOCATE(plvnc(iip1, jjb_v:jje_v, llm))
     960      ALLOCATE(p(iip1, jjb_u:jje_u, llmp1))
     961      ALLOCATE(pls(iip1, jjb_u:jje_u, llm))
     962      ALLOCATE(pext(iip1, jjb_u:jje_u, llm))
     963      ALLOCATE(pbarx(iip1, jjb_u:jje_u, llm))
     964      ALLOCATE(pbary(iip1, jjb_v:jje_v, llm))
     965      ALLOCATE(pk(iip1, jjb_u:jje_u, llm))
     966      ALLOCATE(pks (iip1, jjb_u:jje_u))
     967      ALLOCATE(qsat(ijb_u:ije_u, llm))
     968      ALLOCATE(zu1(iip1, jjb_u:jje_u, llm))
     969      ALLOCATE(zu2(iip1, jjb_u:jje_u, llm))
     970      ALLOCATE(zv1(iip1, jjb_v:jje_v, llm))
     971      ALLOCATE(zv2(iip1, jjb_v:jje_v, llm))
     972      !$OMP END MASTER
     973      !$OMP BARRIER
     974    ENDIF
     975
     976    IF (guide_plevs==0) THEN
     977      !$OMP DO
     978      DO l = 1, nlevnc
     979        DO j = jjbu, jjeu
     980          DO i = 1, iip1
     981            plnc2(i, j, l) = apnc(l)
     982            plnc1(i, j, l) = apnc(l)
     983          ENDDO
     984        ENDDO
     985      ENDDO
     986    ENDIF
     987
     988    IF (first) THEN
     989      first = .FALSE.
     990      !$OMP MASTER
     991      WRITE(*, *)trim(modname) // ' : check vertical level order'
     992      WRITE(*, *)trim(modname) // ' LMDZ :'
     993      do l = 1, llm
     994        WRITE(*, *)trim(modname) // ' PL(', l, ')=', (ap(l) + ap(l + 1)) / 2. &
     995                + psi(1, jjeu) * (bp(l) + bp(l + 1)) / 2.
     996      enddo
     997      WRITE(*, *)trim(modname) // ' nudging file :'
     998      SELECT CASE (guide_plevs)
     999      CASE (0)
     1000        do l = 1, nlevnc
     1001          WRITE(*, *)trim(modname) // ' PL(', l, ')=', plnc2(1, jjbu, l)
     1002        enddo
     1003      CASE (1)
     1004        DO l = 1, nlevnc
     1005          WRITE(*, *)trim(modname) // ' PL(', l, ')=', &
     1006                  apnc(l) + bpnc(l) * psnat2(1, jjbu)
     1007        ENDDO
     1008      CASE (2)
     1009        do l = 1, nlevnc
     1010          WRITE(*, *)trim(modname) // ' PL(', l, ')=', pnat2(1, jjbu, l)
     1011        enddo
     1012      END SELECT
     1013      WRITE(*, *)trim(modname) // ' invert ordering: invert_p=', invert_p
     1014      IF (guide_u) THEN
     1015        do l = 1, nlevnc
     1016          WRITE(*, *)trim(modname) // ' U(', l, ')=', unat2(1, jjbu, l)
     1017        enddo
     1018      endif
     1019      IF (guide_T) THEN
     1020        do l = 1, nlevnc
     1021          WRITE(*, *)trim(modname) // ' T(', l, ')=', tnat2(1, jjbu, l)
     1022        enddo
     1023      endif
     1024      !$OMP END MASTER
     1025    endif ! of if (first)
     1026
     1027    IF (guide_plevs /= 1 .OR. guide_t .AND. .NOT. guide_teta &
     1028            .OR. guide_q .AND. guide_hr) THEN
     1029      CALL pression_loc(ijnb_u, ap, bp, psi, p)
     1030      IF (disvert_type==1) THEN
     1031        CALL exner_hyb_loc(ijnb_u, psi, p, pks, pk)
     1032      else ! we assume that we are in the disvert_type==2 case
     1033        CALL exner_milieu_loc(ijnb_u, psi, p, pks, pk)
     1034      endif
     1035    end if
     1036
     1037    ! -----------------------------------------------------------------
     1038    ! Calcul niveaux pression modele
     1039    ! -----------------------------------------------------------------
     1040
     1041    !    ....  Calcul de pls , pression au milieu des couches ,en Pascals
     1042    IF (guide_plevs==1) THEN
     1043      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1044      DO l = 1, llm
     1045        DO j = jjbu, jjeu
     1046          DO i = 1, iip1
     1047            pls(i, j, l) = (ap(l) + ap(l + 1)) / 2. + psi(i, j) * (bp(l) + bp(l + 1)) / 2.
     1048          ENDDO
     1049        ENDDO
     1050      ENDDO
     1051    ELSE
     1052      unskap = 1. / kappa
     1053      !$OMP BARRIER
     1054      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1055      DO l = 1, llm
     1056        DO j = jjbu, jjeu
     1057          DO i = 1, iip1
     1058            pls(i, j, l) = preff * (pk(i, j, l) / cpp) ** unskap
     1059          ENDDO
     1060        ENDDO
     1061      ENDDO
     1062    ENDIF
     1063
     1064    !   calcul des pressions pour les grilles u et v
     1065    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1066    do l = 1, llm
     1067      do j = jjbu, jjeu
     1068        do i = 1, iip1
     1069          pext(i, j, l) = pls(i, j, l) * aire(i, j)
     1070        enddo
     1071      enddo
     1072    enddo
     1073
     1074    CALL Register_Hallo_u(pext, llm, 1, 2, 2, 1, Req)
     1075    CALL SendRequest(Req)
     1076    !$OMP BARRIER
     1077    CALL WaitRequest(Req)
     1078    !$OMP BARRIER
     1079
     1080    CALL massbar_loc(pext, pbarx, pbary)
     1081    !$OMP BARRIER
     1082    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1083    do l = 1, llm
     1084      do j = jjbu, jjeu
     1085        do i = 1, iip1
     1086          plunc(i, j, l) = pbarx(i, j, l) / aireu(i, j)
     1087          plsnc(i, j, l) = pls(i, j, l)
     1088        enddo
     1089      enddo
     1090    enddo
     1091    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1092    do l = 1, llm
     1093      do j = jjbv, jjev
     1094        do i = 1, iip1
     1095          plvnc(i, j, l) = pbary(i, j, l) / airev(i, j)
     1096        enddo
     1097      enddo
     1098    enddo
     1099
     1100    ! -----------------------------------------------------------------
     1101    ! Interpolation verticale champs guidage sur niveaux modele
     1102    ! Conversion en variables gcm (ucov, vcov...)
     1103    ! -----------------------------------------------------------------
     1104    IF (guide_P) THEN
     1105      !$OMP MASTER
     1106      do j = jjbu, jjeu
     1107        do i = 1, iim
     1108          ij = (j - 1) * iip1 + i
     1109          psgui1(ij) = psnat1(i, j)
     1110          psgui2(ij) = psnat2(i, j)
     1111        enddo
     1112        psgui1(iip1 * j) = psnat1(1, j)
     1113        psgui2(iip1 * j) = psnat2(1, j)
     1114      enddo
     1115      !$OMP END MASTER
     1116      !$OMP BARRIER
     1117    endif
     1118
     1119    IF (guide_T) THEN
     1120      ! Calcul des nouvelles valeurs des niveaux de pression du guidage
     1121      IF (guide_plevs==1) THEN
     1122        !$OMP DO
     1123        DO l = 1, nlevnc
     1124          DO j = jjbu, jjeu
     1125            DO i = 1, iip1
     1126              plnc2(i, j, l) = apnc(l) + bpnc(l) * psnat2(i, j)
     1127              plnc1(i, j, l) = apnc(l) + bpnc(l) * psnat1(i, j)
     1128            ENDDO
     1129          ENDDO
     1130        ENDDO
     1131      ELSE IF (guide_plevs==2) THEN
     1132        !$OMP DO
     1133        DO l = 1, nlevnc
     1134          DO j = jjbu, jjeu
     1135            DO i = 1, iip1
     1136              plnc2(i, j, l) = pnat2(i, j, l)
     1137              plnc1(i, j, l) = pnat1(i, j, l)
     1138            ENDDO
     1139          ENDDO
     1140        ENDDO
     1141      ENDIF
     1142
     1143      ! Interpolation verticale
     1144      !$OMP MASTER
     1145      CALL pres2lev(tnat1(:, jjbu:jjeu, :), zu1(:, jjbu:jjeu, :), nlevnc, llm, &
     1146              plnc1(:, jjbu:jjeu, :), plsnc(:, jjbu:jjeu, :), iip1, jjnu, invert_p)
     1147      CALL pres2lev(tnat2(:, jjbu:jjeu, :), zu2(:, jjbu:jjeu, :), nlevnc, llm, &
     1148              plnc2(:, jjbu:jjeu, :), plsnc(:, jjbu:jjeu, :), iip1, jjnu, invert_p)
     1149      !$OMP END MASTER
     1150      !$OMP BARRIER
     1151      ! Conversion en variables GCM
     1152      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1153      do l = 1, llm
     1154        do j = jjbu, jjeu
     1155          IF (guide_teta) THEN
     1156            do i = 1, iim
     1157              ij = (j - 1) * iip1 + i
     1158              tgui1(ij, l) = zu1(i, j, l)
     1159              tgui2(ij, l) = zu2(i, j, l)
     1160            enddo
     1161          ELSE
     1162            do i = 1, iim
     1163              ij = (j - 1) * iip1 + i
     1164              tgui1(ij, l) = zu1(i, j, l) * cpp / pk(i, j, l)
     1165              tgui2(ij, l) = zu2(i, j, l) * cpp / pk(i, j, l)
     1166            enddo
     1167          ENDIF
     1168          tgui1(j * iip1, l) = tgui1((j - 1) * iip1 + 1, l)
     1169          tgui2(j * iip1, l) = tgui2((j - 1) * iip1 + 1, l)
     1170        enddo
     1171        IF (pole_nord) THEN
     1172          do i = 1, iip1
     1173            tgui1(i, l) = tgui1(1, l)
     1174            tgui2(i, l) = tgui2(1, l)
     1175          enddo
     1176        endif
     1177        IF (pole_sud) THEN
     1178          do i = 1, iip1
     1179            tgui1(ip1jm + i, l) = tgui1(ip1jm + 1, l)
     1180            tgui2(ip1jm + i, l) = tgui2(ip1jm + 1, l)
     1181          enddo
     1182        endif
     1183      enddo
     1184    ENDIF
     1185
     1186    IF (guide_Q) THEN
     1187      ! Calcul des nouvelles valeurs des niveaux de pression du guidage
     1188      IF (guide_plevs==1) THEN
     1189        !$OMP DO
     1190        DO l = 1, nlevnc
     1191          DO j = jjbu, jjeu
     1192            DO i = 1, iip1
     1193              plnc2(i, j, l) = apnc(l) + bpnc(l) * psnat2(i, j)
     1194              plnc1(i, j, l) = apnc(l) + bpnc(l) * psnat1(i, j)
     1195            ENDDO
     1196          ENDDO
     1197        ENDDO
     1198      ELSE IF (guide_plevs==2) THEN
     1199        !$OMP DO
     1200        DO l = 1, nlevnc
     1201          DO j = jjbu, jjeu
     1202            DO i = 1, iip1
     1203              plnc2(i, j, l) = pnat2(i, j, l)
     1204              plnc1(i, j, l) = pnat1(i, j, l)
     1205            ENDDO
     1206          ENDDO
     1207        ENDDO
     1208      ENDIF
     1209
     1210      ! Interpolation verticale
     1211      !$OMP MASTER
     1212      CALL pres2lev(qnat1(:, jjbu:jjeu, :), zu1(:, jjbu:jjeu, :), nlevnc, llm, &
     1213              plnc1(:, jjbu:jjeu, :), plsnc(:, jjbu:jjeu, :), iip1, jjnu, invert_p)
     1214      CALL pres2lev(qnat2(:, jjbu:jjeu, :), zu2(:, jjbu:jjeu, :), nlevnc, llm, &
     1215              plnc2(:, jjbu:jjeu, :), plsnc(:, jjbu:jjeu, :), iip1, jjnu, invert_p)
     1216      !$OMP END MASTER
     1217      !$OMP BARRIER
     1218
     1219      ! Conversion en variables GCM
     1220      ! On suppose qu'on a la bonne variable dans le fichier de guidage:
     1221      ! Hum.Rel si guide_hr, Hum.Spec. sinon.
     1222      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1223      do l = 1, llm
     1224        do j = jjbu, jjeu
     1225          do i = 1, iim
     1226            ij = (j - 1) * iip1 + i
     1227            qgui1(ij, l) = zu1(i, j, l)
     1228            qgui2(ij, l) = zu2(i, j, l)
     1229          enddo
     1230          qgui1(j * iip1, l) = qgui1((j - 1) * iip1 + 1, l)
     1231          qgui2(j * iip1, l) = qgui2((j - 1) * iip1 + 1, l)
     1232        enddo
     1233        IF (pole_nord) THEN
     1234          do i = 1, iip1
     1235            qgui1(i, l) = qgui1(1, l)
     1236            qgui2(i, l) = qgui2(1, l)
     1237          enddo
     1238        endif
     1239        IF (pole_sud) THEN
     1240          do i = 1, iip1
     1241            qgui1(ip1jm + i, l) = qgui1(ip1jm + 1, l)
     1242            qgui2(ip1jm + i, l) = qgui2(ip1jm + 1, l)
     1243          enddo
     1244        endif
     1245      enddo
     1246      IF (guide_hr) THEN
     1247        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1248        do l = 1, llm
     1249          CALL q_sat(iip1 * jjnu, teta(:, jjbu:jjeu, l) * pk(:, jjbu:jjeu, l) / cpp, &
     1250                  plsnc(:, jjbu:jjeu, l), qsat(ijbu:ijeu, l))
     1251          qgui1(ijbu:ijeu, l) = qgui1(ijbu:ijeu, l) * qsat(ijbu:ijeu, l) * 0.01 !hum. rel. en %
     1252          qgui2(ijbu:ijeu, l) = qgui2(ijbu:ijeu, l) * qsat(ijbu:ijeu, l) * 0.01
     1253        enddo
     1254
     1255      ENDIF
     1256    ENDIF
     1257
     1258    IF (guide_u) THEN
     1259      ! Calcul des nouvelles valeurs des niveaux de pression du guidage
     1260      IF (guide_plevs==1) THEN
     1261        !$OMP DO
     1262        DO l = 1, nlevnc
     1263          DO j = jjbu, jjeu
     1264            DO i = 1, iim
     1265              plnc2(i, j, l) = apnc(l) + bpnc(l) * (psnat2(i, j) * aire(i, j) * alpha1p2(i, j) &
     1266                      + psnat2(i + 1, j) * aire(i + 1, j) * alpha3p4(i + 1, j)) / aireu(i, j)
     1267              plnc1(i, j, l) = apnc(l) + bpnc(l) * (psnat1(i, j) * aire(i, j) * alpha1p2(i, j) &
     1268                      + psnat1(i + 1, j) * aire(i + 1, j) * alpha3p4(i + 1, j)) / aireu(i, j)
     1269            ENDDO
     1270            plnc2(iip1, j, l) = plnc2(1, j, l)
     1271            plnc1(iip1, j, l) = plnc1(1, j, l)
     1272          ENDDO
     1273        ENDDO
     1274      ELSE IF (guide_plevs==2) THEN
     1275        !$OMP DO
     1276        DO l = 1, nlevnc
     1277          DO j = jjbu, jjeu
     1278            DO i = 1, iim
     1279              plnc2(i, j, l) = (pnat2(i, j, l) * aire(i, j) * alpha1p2(i, j) &
     1280                      + pnat2(i + 1, j, l) * aire(i, j) * alpha3p4(i + 1, j)) / aireu(i, j)
     1281              plnc1(i, j, l) = (pnat1(i, j, l) * aire(i, j) * alpha1p2(i, j) &
     1282                      + pnat1(i + 1, j, l) * aire(i, j) * alpha3p4(i + 1, j)) / aireu(i, j)
     1283            ENDDO
     1284            plnc2(iip1, j, l) = plnc2(1, j, l)
     1285            plnc1(iip1, j, l) = plnc1(1, j, l)
     1286          ENDDO
     1287        ENDDO
     1288      ENDIF
     1289
     1290      ! Interpolation verticale
     1291      !$OMP MASTER
     1292      CALL pres2lev(unat1(:, jjbu:jjeu, :), zu1(:, jjbu:jjeu, :), nlevnc, llm, &
     1293              plnc1(:, jjbu:jjeu, :), plunc(:, jjbu:jjeu, :), iip1, jjnu, invert_p)
     1294      CALL pres2lev(unat2(:, jjbu:jjeu, :), zu2(:, jjbu:jjeu, :), nlevnc, llm, &
     1295              plnc2(:, jjbu:jjeu, :), plunc(:, jjbu:jjeu, :), iip1, jjnu, invert_p)
     1296      !$OMP END MASTER
     1297      !$OMP BARRIER
     1298
     1299      ! Conversion en variables GCM
     1300      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1301      do l = 1, llm
     1302        do j = jjbu, jjeu
     1303          do i = 1, iim
     1304            ij = (j - 1) * iip1 + i
     1305            ugui1(ij, l) = zu1(i, j, l) * cu(i, j)
     1306            ugui2(ij, l) = zu2(i, j, l) * cu(i, j)
     1307          enddo
     1308          ugui1(j * iip1, l) = ugui1((j - 1) * iip1 + 1, l)
     1309          ugui2(j * iip1, l) = ugui2((j - 1) * iip1 + 1, l)
     1310        enddo
     1311        IF (pole_nord) THEN
     1312          do i = 1, iip1
     1313            ugui1(i, l) = 0.
     1314            ugui2(i, l) = 0.
     1315          enddo
     1316        endif
     1317        IF (pole_sud) THEN
     1318          do i = 1, iip1
     1319            ugui1(ip1jm + i, l) = 0.
     1320            ugui2(ip1jm + i, l) = 0.
     1321          enddo
     1322        endif
     1323      enddo
     1324    ENDIF
     1325
     1326    IF (guide_v) THEN
     1327      ! Calcul des nouvelles valeurs des niveaux de pression du guidage
     1328      IF (guide_plevs==1) THEN
     1329        CALL Register_Hallo_u(psnat1, 1, 1, 2, 2, 1, Req)
     1330        CALL Register_Hallo_u(psnat2, 1, 1, 2, 2, 1, Req)
     1331        CALL SendRequest(Req)
     1332        !$OMP BARRIER
     1333        CALL WaitRequest(Req)
     1334        !$OMP BARRIER
     1335        !$OMP DO
     1336        DO l = 1, nlevnc
     1337          DO j = jjbv, jjev
     1338            DO i = 1, iip1
     1339              plnc2(i, j, l) = apnc(l) + bpnc(l) * (psnat2(i, j) * aire(i, j) * alpha2p3(i, j) &
     1340                      + psnat2(i, j + 1) * aire(i, j + 1) * alpha1p4(i, j + 1)) / airev(i, j)
     1341              plnc1(i, j, l) = apnc(l) + bpnc(l) * (psnat1(i, j) * aire(i, j) * alpha2p3(i, j) &
     1342                      + psnat1(i, j + 1) * aire(i, j + 1) * alpha1p4(i, j + 1)) / airev(i, j)
     1343            ENDDO
     1344          ENDDO
     1345        ENDDO
     1346      ELSE IF (guide_plevs==2) THEN
     1347        CALL Register_Hallo_u(pnat1, llm, 1, 2, 2, 1, Req)
     1348        CALL Register_Hallo_u(pnat2, llm, 1, 2, 2, 1, Req)
     1349        CALL SendRequest(Req)
     1350        !$OMP BARRIER
     1351        CALL WaitRequest(Req)
     1352        !$OMP BARRIER
     1353        !$OMP DO
     1354        DO l = 1, nlevnc
     1355          DO j = jjbv, jjev
     1356            DO i = 1, iip1
     1357              plnc2(i, j, l) = (pnat2(i, j, l) * aire(i, j) * alpha2p3(i, j) &
     1358                      + pnat2(i, j + 1, l) * aire(i, j) * alpha1p4(i, j + 1)) / airev(i, j)
     1359              plnc1(i, j, l) = (pnat1(i, j, l) * aire(i, j) * alpha2p3(i, j) &
     1360                      + pnat1(i, j + 1, l) * aire(i, j) * alpha1p4(i, j + 1)) / airev(i, j)
     1361            ENDDO
     1362          ENDDO
     1363        ENDDO
     1364      ENDIF
     1365      ! Interpolation verticale
     1366
     1367      !$OMP MASTER
     1368      CALL pres2lev(vnat1(:, jjbv:jjev, :), zv1(:, jjbv:jjev, :), nlevnc, llm, &
     1369              plnc1(:, jjbv:jjev, :), plvnc(:, jjbv:jjev, :), iip1, jjnv, invert_p)
     1370      CALL pres2lev(vnat2(:, jjbv:jjev, :), zv2(:, jjbv:jjev, :), nlevnc, llm, &
     1371              plnc2(:, jjbv:jjev, :), plvnc(:, jjbv:jjev, :), iip1, jjnv, invert_p)
     1372      !$OMP END MASTER
     1373      !$OMP BARRIER
     1374      ! Conversion en variables GCM
     1375      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1376      do l = 1, llm
     1377        do j = jjbv, jjev
     1378          do i = 1, iim
     1379            ij = (j - 1) * iip1 + i
     1380            vgui1(ij, l) = zv1(i, j, l) * cv(i, j)
     1381            vgui2(ij, l) = zv2(i, j, l) * cv(i, j)
     1382          enddo
     1383          vgui1(j * iip1, l) = vgui1((j - 1) * iip1 + 1, l)
     1384          vgui2(j * iip1, l) = vgui2((j - 1) * iip1 + 1, l)
     1385        enddo
     1386      enddo
     1387    ENDIF
     1388
     1389  END SUBROUTINE guide_interp
     1390
     1391  !=======================================================================
     1392  SUBROUTINE tau2alpha(typ, pim, jjb, jje, factt, taumin, taumax, alpha)
     1393
     1394    ! Calcul des constantes de rappel alpha (=1/tau)
     1395
     1396    USE comconst_mod, ONLY: pi
     1397    USE serre_mod, ONLY: clat, clon, grossismx, grossismy
     1398
     1399    IMPLICIT NONE
     1400
     1401    include "dimensions.h"
     1402    include "paramet.h"
     1403    include "comgeom2.h"
     1404
     1405    ! input arguments :
    14151406    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
    14161407    INTEGER, INTENT(IN) :: pim ! dimensions en lon
    1417     INTEGER, INTENT(IN) :: jjb,jje ! dimensions en lat
    1418     REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
    1419     REAL, INTENT(IN)    :: taumin,taumax
    1420 ! output arguments:
    1421     REAL, DIMENSION(pim,jjb:jje), INTENT(OUT) :: alpha
    1422  
    1423 !  local variables:
    1424     LOGICAL, SAVE               :: first=.TRUE.
    1425     REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
    1426     REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
    1427     REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
    1428     REAL, DIMENSION (iip1,jjm)  :: dxdyv
    1429     real dxdy_
    1430     real zlat,zlon
    1431     real alphamin,alphamax,xi
    1432     integer i,j,ilon,ilat
    1433     CHARACTER(LEN=20),parameter :: modname="tau2alpha"
    1434 
    1435 
    1436     alphamin=factt/taumax
    1437     alphamax=factt/taumin
     1408    INTEGER, INTENT(IN) :: jjb, jje ! dimensions en lat
     1409    REAL, INTENT(IN) :: factt   ! pas de temps en fraction de jour
     1410    REAL, INTENT(IN) :: taumin, taumax
     1411    ! output arguments:
     1412    REAL, DIMENSION(pim, jjb:jje), INTENT(OUT) :: alpha
     1413
     1414    !  local variables:
     1415    LOGICAL, SAVE :: first = .TRUE.
     1416    REAL, SAVE :: gamma, dxdy_min, dxdy_max
     1417    REAL, DIMENSION (iip1, jjp1) :: zdx, zdy
     1418    REAL, DIMENSION (iip1, jjp1) :: dxdys, dxdyu
     1419    REAL, DIMENSION (iip1, jjm) :: dxdyv
     1420    REAL dxdy_
     1421    REAL zlat, zlon
     1422    REAL alphamin, alphamax, xi
     1423    INTEGER i, j, ilon, ilat
     1424    CHARACTER(LEN = 20), parameter :: modname = "tau2alpha"
     1425
     1426    alphamin = factt / taumax
     1427    alphamax = factt / taumin
    14381428    IF (guide_reg.OR.guide_add) THEN
    1439         alpha=alphamax
    1440 !-----------------------------------------------------------------------
    1441 ! guide_reg: alpha=alpha_min dans region, 0. sinon.
    1442 !-----------------------------------------------------------------------
    1443         IF (guide_reg) THEN
    1444             do j=jjb,jje
    1445                 do i=1,pim
    1446                     if (typ==2) THEN
    1447                        zlat=rlatu(j)*180./pi
    1448                        zlon=rlonu(i)*180./pi
    1449                     elseif (typ==1) THEN
    1450                        zlat=rlatu(j)*180./pi
    1451                        zlon=rlonv(i)*180./pi
    1452                     elseif (typ==3) THEN
    1453                        zlat=rlatv(j)*180./pi
    1454                        zlon=rlonv(i)*180./pi
    1455                     endif
    1456                     alpha(i,j)=alphamax/16.* &
    1457                               (1.+tanh((zlat-lat_min_g)/tau_lat))* &
    1458                               (1.+tanh((lat_max_g-zlat)/tau_lat))* &
    1459                               (1.+tanh((zlon-lon_min_g)/tau_lon))* &
    1460                               (1.+tanh((lon_max_g-zlon)/tau_lon))
    1461                 enddo
    1462             enddo
    1463         ENDIF
     1429      alpha = alphamax
     1430      !-----------------------------------------------------------------------
     1431      ! guide_reg: alpha=alpha_min dans region, 0. sinon.
     1432      !-----------------------------------------------------------------------
     1433      IF (guide_reg) THEN
     1434        do j = jjb, jje
     1435          do i = 1, pim
     1436            IF (typ==2) THEN
     1437              zlat = rlatu(j) * 180. / pi
     1438              zlon = rlonu(i) * 180. / pi
     1439            elseif (typ==1) THEN
     1440              zlat = rlatu(j) * 180. / pi
     1441              zlon = rlonv(i) * 180. / pi
     1442            elseif (typ==3) THEN
     1443              zlat = rlatv(j) * 180. / pi
     1444              zlon = rlonv(i) * 180. / pi
     1445            endif
     1446            alpha(i, j) = alphamax / 16. * &
     1447                    (1. + tanh((zlat - lat_min_g) / tau_lat)) * &
     1448                    (1. + tanh((lat_max_g - zlat) / tau_lat)) * &
     1449                    (1. + tanh((zlon - lon_min_g) / tau_lon)) * &
     1450                    (1. + tanh((lon_max_g - zlon) / tau_lon))
     1451          enddo
     1452        enddo
     1453      ENDIF
    14641454    ELSE
    1465 !-----------------------------------------------------------------------
    1466 ! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
    1467 !-----------------------------------------------------------------------
    1468 !Calcul de l'aire des mailles
    1469         do j=2,jjm
    1470             do i=2,iip1
    1471                zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
    1472             enddo
    1473             zdx(1,j)=zdx(iip1,j)
     1455      !-----------------------------------------------------------------------
     1456      ! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
     1457      !-----------------------------------------------------------------------
     1458      !Calcul de l'aire des mailles
     1459      do j = 2, jjm
     1460        do i = 2, iip1
     1461          zdx(i, j) = 0.5 * (cu(i - 1, j) + cu(i, j)) / cos(rlatu(j))
    14741462        enddo
    1475         do j=2,jjm
    1476             do i=1,iip1
    1477                zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
    1478             enddo
     1463        zdx(1, j) = zdx(iip1, j)
     1464      enddo
     1465      do j = 2, jjm
     1466        do i = 1, iip1
     1467          zdy(i, j) = 0.5 * (cv(i, j - 1) + cv(i, j))
    14791468        enddo
    1480         do i=1,iip1
    1481             zdx(i,1)=zdx(i,2)
    1482             zdx(i,jjp1)=zdx(i,jjm)
    1483             zdy(i,1)=zdy(i,2)
    1484             zdy(i,jjp1)=zdy(i,jjm)
     1469      enddo
     1470      do i = 1, iip1
     1471        zdx(i, 1) = zdx(i, 2)
     1472        zdx(i, jjp1) = zdx(i, jjm)
     1473        zdy(i, 1) = zdy(i, 2)
     1474        zdy(i, jjp1) = zdy(i, jjm)
     1475      enddo
     1476      do j = 1, jjp1
     1477        do i = 1, iip1
     1478          dxdys(i, j) = sqrt(zdx(i, j) * zdx(i, j) + zdy(i, j) * zdy(i, j))
    14851479        enddo
    1486         do j=1,jjp1
    1487             do i=1,iip1
    1488                dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
    1489             enddo
     1480      enddo
     1481      IF (typ==2) THEN
     1482        do j = 1, jjp1
     1483          do i = 1, iim
     1484            dxdyu(i, j) = 0.5 * (dxdys(i, j) + dxdys(i + 1, j))
     1485          enddo
     1486          dxdyu(iip1, j) = dxdyu(1, j)
    14901487        enddo
    1491         IF (typ==2) THEN
    1492             do j=1,jjp1
    1493                 do i=1,iim
    1494                    dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
    1495                 enddo
    1496                 dxdyu(iip1,j)=dxdyu(1,j)
    1497             enddo
    1498         ENDIF
    1499         IF (typ==3) THEN
    1500             do j=1,jjm
    1501                 do i=1,iip1
    1502                    dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
    1503                 enddo
    1504             enddo
    1505         ENDIF
    1506 ! Premier appel: calcul des aires min et max et de gamma.
    1507         IF (first) THEN
    1508             first=.FALSE.
    1509             ! coordonnees du centre du zoom
    1510             CALL coordij(clon,clat,ilon,ilat)
    1511             ! aire de la maille au centre du zoom
    1512             dxdy_min=dxdys(ilon,ilat)
    1513             ! dxdy maximale de la maille
    1514             dxdy_max=0.
    1515             do j=1,jjp1
    1516                 do i=1,iip1
    1517                      dxdy_max=max(dxdy_max,dxdys(i,j))
    1518                 enddo
    1519             enddo
    1520             ! Calcul de gamma
    1521             if (abs(grossismx-1.)<0.1.or.abs(grossismy-1.)<0.1) THEN
    1522               WRITE(*,*)trim(modname)//' ATTENTION modele peu zoome'
    1523               WRITE(*,*)trim(modname)//' ATTENTION on prend une constante de guidage cste'
    1524               gamma=0.
     1488      ENDIF
     1489      IF (typ==3) THEN
     1490        do j = 1, jjm
     1491          do i = 1, iip1
     1492            dxdyv(i, j) = 0.5 * (dxdys(i, j) + dxdys(i, j + 1))
     1493          enddo
     1494        enddo
     1495      ENDIF
     1496      ! Premier appel: calcul des aires min et max et de gamma.
     1497      IF (first) THEN
     1498        first = .FALSE.
     1499        ! coordonnees du centre du zoom
     1500        CALL coordij(clon, clat, ilon, ilat)
     1501        ! aire de la maille au centre du zoom
     1502        dxdy_min = dxdys(ilon, ilat)
     1503        ! dxdy maximale de la maille
     1504        dxdy_max = 0.
     1505        do j = 1, jjp1
     1506          do i = 1, iip1
     1507            dxdy_max = max(dxdy_max, dxdys(i, j))
     1508          enddo
     1509        enddo
     1510        ! Calcul de gamma
     1511        IF (abs(grossismx - 1.)<0.1.OR.abs(grossismy - 1.)<0.1) THEN
     1512          WRITE(*, *)trim(modname) // ' ATTENTION modele peu zoome'
     1513          WRITE(*, *)trim(modname) // ' ATTENTION on prend une constante de guidage cste'
     1514          gamma = 0.
     1515        else
     1516          gamma = (dxdy_max - 2. * dxdy_min) / (dxdy_max - dxdy_min)
     1517          WRITE(*, *)trim(modname) // ' gamma=', gamma
     1518          IF (gamma<1.e-5) THEN
     1519            WRITE(*, *)trim(modname) // ' gamma =', gamma, '<1e-5'
     1520            CALL abort_gcm("guide_loc_mod", "stopped", 1)
     1521          endif
     1522          gamma = log(0.5) / log(gamma)
     1523          IF (gamma4) THEN
     1524            gamma = min(gamma, 4.)
     1525          endif
     1526          WRITE(*, *)trim(modname) // ' gamma=', gamma
     1527        endif
     1528      ENDIF !first
     1529
     1530      do j = jjb, jje
     1531        do i = 1, pim
     1532          IF (typ==1) THEN
     1533            dxdy_ = dxdys(i, j)
     1534            zlat = rlatu(j) * 180. / pi
     1535          elseif (typ==2) THEN
     1536            dxdy_ = dxdyu(i, j)
     1537            zlat = rlatu(j) * 180. / pi
     1538          elseif (typ==3) THEN
     1539            dxdy_ = dxdyv(i, j)
     1540            zlat = rlatv(j) * 180. / pi
     1541          endif
     1542          IF (abs(grossismx - 1.)<0.1.OR.abs(grossismy - 1.)<0.1) THEN
     1543            ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
     1544            alpha(i, j) = alphamin
     1545          else
     1546            xi = ((dxdy_max - dxdy_) / (dxdy_max - dxdy_min))**gamma
     1547            xi = min(xi, 1.)
     1548            IF(lat_min_g<=zlat .AND. zlat<=lat_max_g) THEN
     1549              alpha(i, j) = xi * alphamin + (1. - xi) * alphamax
    15251550            else
    1526               gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
    1527               WRITE(*,*)trim(modname)//' gamma=',gamma
    1528               if (gamma<1.e-5) THEN
    1529                 WRITE(*,*)trim(modname)//' gamma =',gamma,'<1e-5'
    1530                 CALL abort_gcm("guide_loc_mod","stopped",1)
    1531               endif
    1532               gamma=log(0.5)/log(gamma)
    1533               if (gamma4) THEN
    1534                 gamma=min(gamma,4.)
    1535               endif
    1536               WRITE(*,*)trim(modname)//' gamma=',gamma
     1551              alpha(i, j) = 0.
    15371552            endif
    1538         ENDIF !first
    1539 
    1540         do j=jjb,jje
    1541             do i=1,pim
    1542                 if (typ==1) THEN
    1543                    dxdy_=dxdys(i,j)
    1544                    zlat=rlatu(j)*180./pi
    1545                 elseif (typ==2) THEN
    1546                    dxdy_=dxdyu(i,j)
    1547                    zlat=rlatu(j)*180./pi
    1548                 elseif (typ==3) THEN
    1549                    dxdy_=dxdyv(i,j)
    1550                    zlat=rlatv(j)*180./pi
    1551                 endif
    1552                 if (abs(grossismx-1.)<0.1.or.abs(grossismy-1.)<0.1) THEN
    1553                 ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
    1554                     alpha(i,j)=alphamin
    1555                 else
    1556                     xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
    1557                     xi=min(xi,1.)
    1558                     IF(lat_min_g<=zlat .and. zlat<=lat_max_g) THEN
    1559                         alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
    1560                     else
    1561                         alpha(i,j)=0.
    1562                     endif
    1563                 endif
    1564             enddo
     1553          endif
    15651554        enddo
     1555      enddo
    15661556    ENDIF ! guide_reg
    15671557
    1568     if (.not. guide_add) alpha = 1. - exp(- alpha)
     1558    IF (.NOT. guide_add) alpha = 1. - exp(- alpha)
    15691559
    15701560  END SUBROUTINE tau2alpha
    15711561
    1572 !=======================================================================
     1562  !=======================================================================
    15731563  SUBROUTINE guide_read(timestep)
    15741564
    … …  
    15781568    include "paramet.h"
    15791569
    1580     INTEGER, INTENT(IN)   :: timestep
    1581 
    1582     LOGICAL, SAVE         :: first=.TRUE.
    1583 ! Identification fichiers et variables NetCDF:
    1584     INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
    1585     INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
    1586     INTEGER               :: ncidpl,varidpl,varidap,varidbp,dimid,lendim
    1587 ! Variables auxiliaires NetCDF:
    1588     INTEGER, DIMENSION(4) :: start,count
    1589     INTEGER               :: status,rcode
    1590     CHARACTER (len = 80)   :: abort_message
    1591     CHARACTER (len = 20)   :: modname = 'guide_read'
    1592     CHARACTER (len = 20)   :: namedim
    1593     abort_message='pb in guide_read'
    1594 
    1595 ! -----------------------------------------------------------------
    1596 ! Premier appel: initialisation de la lecture des fichiers
    1597 ! -----------------------------------------------------------------
    1598     if (first) THEN
    1599          ncidpl=-99
    1600          WRITE(*,*) trim(modname)//': opening nudging files '
    1601 ! Ap et Bp si Niveaux de pression hybrides
    1602          if (guide_plevs==1) THEN
    1603              WRITE(*,*) trim(modname)//' Reading nudging on model levels'
    1604              rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
    1605              IF (rcode/=nf90_noerr) THEN
    1606               abort_message='Nudging: error -> no file apbp.nc'
    1607               CALL abort_gcm(modname,abort_message,1)
    1608              ENDIF
    1609              rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
    1610              IF (rcode/=nf90_noerr) THEN
    1611               abort_message='Nudging: error -> no AP variable in file apbp.nc'
    1612               CALL abort_gcm(modname,abort_message,1)
    1613              ENDIF
    1614              rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
    1615              IF (rcode/=nf90_noerr) THEN
    1616               abort_message='Nudging: error -> no BP variable in file apbp.nc'
    1617               CALL abort_gcm(modname,abort_message,1)
    1618              ENDIF
    1619              WRITE(*,*) trim(modname)//' ncidpl,varidap',ncidpl,varidap
    1620          endif
    1621          
    1622 ! Pression si guidage sur niveaux P variables
    1623          if (guide_plevs==2) THEN
    1624              rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
    1625              IF (rcode/=nf90_noerr) THEN
    1626               abort_message='Nudging: error -> no file P.nc'
    1627               CALL abort_gcm(modname,abort_message,1)
    1628              ENDIF
    1629              rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
    1630              IF (rcode/=nf90_noerr) THEN
    1631               abort_message='Nudging: error -> no PRES variable in file P.nc'
    1632               CALL abort_gcm(modname,abort_message,1)
    1633              ENDIF
    1634              WRITE(*,*) trim(modname)//' ncidp,varidp',ncidp,varidp
    1635              if (ncidpl==-99) ncidpl=ncidp
    1636          endif
    1637 
    1638 ! Vent zonal
    1639          if (guide_u) THEN
    1640              rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
    1641              IF (rcode/=nf90_noerr) THEN
    1642               abort_message='Nudging: error -> no file u.nc'
    1643               CALL abort_gcm(modname,abort_message,1)
    1644              ENDIF
    1645              rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
    1646              IF (rcode/=nf90_noerr) THEN
    1647               abort_message='Nudging: error -> no UWND variable in file u.nc'
    1648               CALL abort_gcm(modname,abort_message,1)
    1649              ENDIF
    1650              WRITE(*,*) trim(modname)//' ncidu,varidu',ncidu,varidu
    1651              if (ncidpl==-99) ncidpl=ncidu
    1652 
    1653    
    1654              status=nf90_inq_dimid(ncidu, "LONU", dimid)
    1655              status=nf90_inquire_dimension(ncidu,dimid,namedim,lendim)
    1656              IF (lendim /= iip1) THEN
    1657                 abort_message='dimension LONU different from iip1 in u.nc'
    1658                 CALL abort_gcm(modname,abort_message,1)
    1659              ENDIF
    1660 
    1661              status=nf90_inq_dimid(ncidu, "LATU", dimid)
    1662              status=nf90_inquire_dimension(ncidu,dimid,namedim,lendim)
    1663              IF (lendim /= jjp1) THEN
    1664                 abort_message='dimension LATU different from jjp1 in u.nc'
    1665                 CALL abort_gcm(modname,abort_message,1)
    1666              ENDIF
    1667  
    1668          endif
    1669 
    1670 ! Vent meridien
    1671          if (guide_v) THEN
    1672              rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
    1673              IF (rcode/=nf90_noerr) THEN
    1674               abort_message='Nudging: error -> no file v.nc'
    1675               CALL abort_gcm(modname,abort_message,1)
    1676              ENDIF
    1677              rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
    1678              IF (rcode/=nf90_noerr) THEN
    1679               abort_message='Nudging: error -> no VWND variable in file v.nc'
    1680               CALL abort_gcm(modname,abort_message,1)
    1681              ENDIF
    1682              WRITE(*,*) trim(modname)//' ncidv,varidv',ncidv,varidv
    1683              if (ncidpl==-99) ncidpl=ncidv
    1684              
    1685              status=nf90_inq_dimid(ncidv, "LONV", dimid)
    1686              status=nf90_inquire_dimension(ncidv,dimid,namedim,lendim)
    1687              
    1688                 IF (lendim /= iip1) THEN
    1689                 abort_message='dimension LONV different from iip1 in v.nc'
    1690                 CALL abort_gcm(modname,abort_message,1)
    1691              ENDIF
    1692 
    1693 
    1694              status=nf90_inq_dimid(ncidv, "LATV", dimid)
    1695              status=nf90_inquire_dimension(ncidv,dimid,namedim,lendim)
    1696              IF (lendim /= jjm) THEN
    1697                 abort_message='dimension LATV different from jjm in v.nc'
    1698                 CALL abort_gcm(modname,abort_message,1)
    1699              ENDIF
    1700        
    1701         endif
    1702 
    1703 ! Temperature
    1704          if (guide_T) THEN
    1705              rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
    1706              IF (rcode/=nf90_noerr) THEN
    1707               abort_message='Nudging: error -> no file T.nc'
    1708               CALL abort_gcm(modname,abort_message,1)
    1709              ENDIF
    1710              rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
    1711              IF (rcode/=nf90_noerr) THEN
    1712               abort_message='Nudging: error -> no AIR variable in file T.nc'
    1713               CALL abort_gcm(modname,abort_message,1)
    1714              ENDIF
    1715              WRITE(*,*) trim(modname)//' ncidT,varidT',ncidt,varidt
    1716              if (ncidpl==-99) ncidpl=ncidt
    1717 
    1718              status=nf90_inq_dimid(ncidt, "LONV", dimid)
    1719              status=nf90_inquire_dimension(ncidt,dimid,namedim,lendim)
    1720              IF (lendim /= iip1) THEN
    1721                 abort_message='dimension LONV different from iip1 in T.nc'
    1722                 CALL abort_gcm(modname,abort_message,1)
    1723              ENDIF
    1724 
    1725              status=nf90_inq_dimid(ncidt, "LATU", dimid)
    1726              status=nf90_inquire_dimension(ncidt,dimid,namedim,lendim)
    1727              IF (lendim /= jjp1) THEN
    1728                 abort_message='dimension LATU different from jjp1 in T.nc'
    1729                 CALL abort_gcm(modname,abort_message,1)
    1730              ENDIF
    1731 
    1732          endif
    1733 
    1734 ! Humidite
    1735          if (guide_Q) THEN
    1736              rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
    1737              IF (rcode/=nf90_noerr) THEN
    1738               abort_message='Nudging: error -> no file hur.nc'
    1739               CALL abort_gcm(modname,abort_message,1)
    1740              ENDIF
    1741              rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
    1742              IF (rcode/=nf90_noerr) THEN
    1743               abort_message='Nudging: error -> no RH variable in file hur.nc'
    1744               CALL abort_gcm(modname,abort_message,1)
    1745              ENDIF
    1746              WRITE(*,*) trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
    1747              if (ncidpl==-99) ncidpl=ncidQ
    1748 
    1749 
    1750              status=nf90_inq_dimid(ncidQ, "LONV", dimid)
    1751              status=nf90_inquire_dimension(ncidQ,dimid,namedim,lendim)
    1752              IF (lendim /= iip1) THEN
    1753                 abort_message='dimension LONV different from iip1 in hur.nc'
    1754                 CALL abort_gcm(modname,abort_message,1)
    1755              ENDIF
    1756 
    1757              status=nf90_inq_dimid(ncidQ, "LATU", dimid)
    1758              status=nf90_inquire_dimension(ncidQ,dimid,namedim,lendim)
    1759              IF (lendim /= jjp1) THEN
    1760                 abort_message='dimension LATU different from jjp1 in hur.nc'
    1761                 CALL abort_gcm(modname,abort_message,1)
    1762              ENDIF
    1763 
    1764 
    1765          endif
    1766 ! Pression de surface
    1767          if ((guide_P).OR.(guide_plevs==1)) THEN
    1768              rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
    1769              IF (rcode/=nf90_noerr) THEN
    1770               abort_message='Nudging: error -> no file ps.nc'
    1771               CALL abort_gcm(modname,abort_message,1)
    1772              ENDIF
    1773              rcode = nf90_inq_varid(ncidps, 'SP', varidps)
    1774              IF (rcode/=nf90_noerr) THEN
    1775               abort_message='Nudging: error -> no SP variable in file ps.nc'
    1776               CALL abort_gcm(modname,abort_message,1)
    1777              ENDIF
    1778              WRITE(*,*) trim(modname)//' ncidps,varidps',ncidps,varidps
    1779          endif
    1780 ! Coordonnee verticale
    1781          if (guide_plevs==0) THEN
    1782               rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
    1783               IF (rcode/=0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
    1784               WRITE(*,*) trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
    1785          endif
    1786 ! Coefs ap, bp pour calcul de la pression aux differents niveaux
    1787          IF (guide_plevs==1) THEN
    1788              status=nf90_put_var(ncidpl,varidap,apnc,[1],[nlevnc])
    1789              status=nf90_put_var(ncidpl,varidbp,bpnc,[1],[nlevnc])
    1790          ELSEIF (guide_plevs==0) THEN
    1791              status=nf90_put_var(ncidpl,varidpl,apnc,[1],[nlevnc])
    1792 !FC Pour les corrections la pression est deja en Pascals on commente la ligne ci-dessous
    1793              IF(convert_Pa) apnc=apnc*100.! conversion en Pascals
    1794              bpnc(:)=0.
    1795          ENDIF
    1796          first=.FALSE.
    1797      ENDIF ! (first)
    1798 
    1799 ! -----------------------------------------------------------------
    1800 !   lecture des champs u, v, T, Q, ps
    1801 ! -----------------------------------------------------------------
    1802 
    1803 !  dimensions pour les champs scalaires et le vent zonal
    1804      start(1)=1
    1805      start(2)=jjb_u
    1806      start(3)=1
    1807      start(4)=timestep
    1808 
    1809      count(1)=iip1
    1810      count(2)=jjnb_u
    1811      count(3)=nlevnc
    1812      count(4)=1
    1813 
    1814      IF (invert_y) start(2)=jjp1-jje_u+1
    1815 ! Pression
    1816      if (guide_plevs==2) THEN
    1817          status=nf90_put_var(ncidp,varidp,pnat2,start,count)
    1818          IF (invert_y) THEN
    1819 !           PRINT*,"Invertion impossible actuellement"
    1820 !           CALL abort_gcm(modname,abort_message,1)
    1821            CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
    1822          ENDIF
    1823      endif
    1824 
    1825 !  Vent zonal
    1826      if (guide_u) THEN
    1827          status=nf90_put_var(ncidu,varidu,unat2,start,count)
    1828          IF (invert_y) THEN
    1829 !           PRINT*,"Invertion impossible actuellement"
    1830 !           CALL abort_gcm(modname,abort_message,1)
    1831            CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
    1832          ENDIF
    1833 
    1834      endif
    1835 
    1836 
    1837 !  Temperature
    1838      if (guide_T) THEN
    1839          status=nf90_put_var(ncidt,varidt,tnat2,start,count)
    1840          IF (invert_y) THEN
    1841 !           PRINT*,"Invertion impossible actuellement"
    1842 !           CALL abort_gcm(modname,abort_message,1)
    1843            CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
    1844          ENDIF
    1845      endif
    1846 
    1847 !  Humidite
    1848      if (guide_Q) THEN
    1849          status=nf90_put_var(ncidQ,varidQ,qnat2,start,count)
    1850          IF (invert_y) THEN
    1851 !           PRINT*,"Invertion impossible actuellement"
    1852 !           CALL abort_gcm(modname,abort_message,1)
    1853            CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
    1854          ENDIF
    1855 
    1856      endif
    1857 
    1858 !  Vent meridien
    1859      if (guide_v) THEN
    1860          start(2)=jjb_v
    1861          count(2)=jjnb_v
    1862          IF (invert_y) start(2)=jjm-jje_v+1
    1863 
    1864          status=nf90_put_var(ncidv,varidv,vnat2,start,count)
    1865          IF (invert_y) THEN
    1866 !           PRINT*,"Invertion impossible actuellement"
    1867 !           CALL abort_gcm(modname,abort_message,1)
    1868            CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
    1869          ENDIF
    1870      endif
    1871 
    1872 !  Pression de surface
    1873      if ((guide_P).OR.(guide_plevs==1))  THEN
    1874          start(2)=jjb_u
    1875          start(3)=timestep
    1876          start(4)=0
    1877          count(2)=jjnb_u
    1878          count(3)=1
    1879          count(4)=0
    1880          IF (invert_y) start(2)=jjp1-jje_u+1
    1881          status=nf90_put_var(ncidps,varidps,psnat2,start,count)
    1882          IF (invert_y) THEN
    1883 !           PRINT*,"Invertion impossible actuellement"
    1884 !           CALL abort_gcm(modname,abort_message,1)
    1885            CALL invert_lat(iip1,jjnb_u,1,psnat2)
    1886          ENDIF
    1887      endif
     1570    INTEGER, INTENT(IN) :: timestep
     1571
     1572    LOGICAL, SAVE :: first = .TRUE.
     1573    ! Identification fichiers et variables NetCDF:
     1574    INTEGER, SAVE :: ncidu, varidu, ncidv, varidv, ncidp, varidp
     1575    INTEGER, SAVE :: ncidQ, varidQ, ncidt, varidt, ncidps, varidps
     1576    INTEGER :: ncidpl, varidpl, varidap, varidbp, dimid, lendim
     1577    ! Variables auxiliaires NetCDF:
     1578    INTEGER, DIMENSION(4) :: start, count
     1579    INTEGER :: status, rcode
     1580    CHARACTER (len = 80) :: abort_message
     1581    CHARACTER (len = 20) :: modname = 'guide_read'
     1582    CHARACTER (len = 20) :: namedim
     1583    abort_message = 'pb in guide_read'
     1584
     1585    ! -----------------------------------------------------------------
     1586    ! Premier appel: initialisation de la lecture des fichiers
     1587    ! -----------------------------------------------------------------
     1588    IF (first) THEN
     1589      ncidpl = -99
     1590      WRITE(*, *) trim(modname) // ': opening nudging files '
     1591      ! Ap et Bp si Niveaux de pression hybrides
     1592      IF (guide_plevs==1) THEN
     1593        WRITE(*, *) trim(modname) // ' Reading nudging on model levels'
     1594        rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
     1595        IF (rcode/=nf90_noerr) THEN
     1596          abort_message = 'Nudging: error -> no file apbp.nc'
     1597          CALL abort_gcm(modname, abort_message, 1)
     1598        ENDIF
     1599        rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
     1600        IF (rcode/=nf90_noerr) THEN
     1601          abort_message = 'Nudging: error -> no AP variable in file apbp.nc'
     1602          CALL abort_gcm(modname, abort_message, 1)
     1603        ENDIF
     1604        rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
     1605        IF (rcode/=nf90_noerr) THEN
     1606          abort_message = 'Nudging: error -> no BP variable in file apbp.nc'
     1607          CALL abort_gcm(modname, abort_message, 1)
     1608        ENDIF
     1609        WRITE(*, *) trim(modname) // ' ncidpl,varidap', ncidpl, varidap
     1610      endif
     1611
     1612      ! Pression si guidage sur niveaux P variables
     1613      IF (guide_plevs==2) THEN
     1614        rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
     1615        IF (rcode/=nf90_noerr) THEN
     1616          abort_message = 'Nudging: error -> no file P.nc'
     1617          CALL abort_gcm(modname, abort_message, 1)
     1618        ENDIF
     1619        rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
     1620        IF (rcode/=nf90_noerr) THEN
     1621          abort_message = 'Nudging: error -> no PRES variable in file P.nc'
     1622          CALL abort_gcm(modname, abort_message, 1)
     1623        ENDIF
     1624        WRITE(*, *) trim(modname) // ' ncidp,varidp', ncidp, varidp
     1625        IF (ncidpl==-99) ncidpl = ncidp
     1626      endif
     1627
     1628      ! Vent zonal
     1629      IF (guide_u) THEN
     1630        rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
     1631        IF (rcode/=nf90_noerr) THEN
     1632          abort_message = 'Nudging: error -> no file u.nc'
     1633          CALL abort_gcm(modname, abort_message, 1)
     1634        ENDIF
     1635        rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
     1636        IF (rcode/=nf90_noerr) THEN
     1637          abort_message = 'Nudging: error -> no UWND variable in file u.nc'
     1638          CALL abort_gcm(modname, abort_message, 1)
     1639        ENDIF
     1640        WRITE(*, *) trim(modname) // ' ncidu,varidu', ncidu, varidu
     1641        IF (ncidpl==-99) ncidpl = ncidu
     1642
     1643        status = nf90_inq_dimid(ncidu, "LONU", dimid)
     1644        status = nf90_inquire_dimension(ncidu, dimid, namedim, lendim)
     1645        IF (lendim /= iip1) THEN
     1646          abort_message = 'dimension LONU different from iip1 in u.nc'
     1647          CALL abort_gcm(modname, abort_message, 1)
     1648        ENDIF
     1649
     1650        status = nf90_inq_dimid(ncidu, "LATU", dimid)
     1651        status = nf90_inquire_dimension(ncidu, dimid, namedim, lendim)
     1652        IF (lendim /= jjp1) THEN
     1653          abort_message = 'dimension LATU different from jjp1 in u.nc'
     1654          CALL abort_gcm(modname, abort_message, 1)
     1655        ENDIF
     1656
     1657      endif
     1658
     1659      ! Vent meridien
     1660      IF (guide_v) THEN
     1661        rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
     1662        IF (rcode/=nf90_noerr) THEN
     1663          abort_message = 'Nudging: error -> no file v.nc'
     1664          CALL abort_gcm(modname, abort_message, 1)
     1665        ENDIF
     1666        rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
     1667        IF (rcode/=nf90_noerr) THEN
     1668          abort_message = 'Nudging: error -> no VWND variable in file v.nc'
     1669          CALL abort_gcm(modname, abort_message, 1)
     1670        ENDIF
     1671        WRITE(*, *) trim(modname) // ' ncidv,varidv', ncidv, varidv
     1672        IF (ncidpl==-99) ncidpl = ncidv
     1673
     1674        status = nf90_inq_dimid(ncidv, "LONV", dimid)
     1675        status = nf90_inquire_dimension(ncidv, dimid, namedim, lendim)
     1676
     1677        IF (lendim /= iip1) THEN
     1678          abort_message = 'dimension LONV different from iip1 in v.nc'
     1679          CALL abort_gcm(modname, abort_message, 1)
     1680        ENDIF
     1681
     1682        status = nf90_inq_dimid(ncidv, "LATV", dimid)
     1683        status = nf90_inquire_dimension(ncidv, dimid, namedim, lendim)
     1684        IF (lendim /= jjm) THEN
     1685          abort_message = 'dimension LATV different from jjm in v.nc'
     1686          CALL abort_gcm(modname, abort_message, 1)
     1687        ENDIF
     1688
     1689      endif
     1690
     1691      ! Temperature
     1692      IF (guide_T) THEN
     1693        rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
     1694        IF (rcode/=nf90_noerr) THEN
     1695          abort_message = 'Nudging: error -> no file T.nc'
     1696          CALL abort_gcm(modname, abort_message, 1)
     1697        ENDIF
     1698        rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
     1699        IF (rcode/=nf90_noerr) THEN
     1700          abort_message = 'Nudging: error -> no AIR variable in file T.nc'
     1701          CALL abort_gcm(modname, abort_message, 1)
     1702        ENDIF
     1703        WRITE(*, *) trim(modname) // ' ncidT,varidT', ncidt, varidt
     1704        IF (ncidpl==-99) ncidpl = ncidt
     1705
     1706        status = nf90_inq_dimid(ncidt, "LONV", dimid)
     1707        status = nf90_inquire_dimension(ncidt, dimid, namedim, lendim)
     1708        IF (lendim /= iip1) THEN
     1709          abort_message = 'dimension LONV different from iip1 in T.nc'
     1710          CALL abort_gcm(modname, abort_message, 1)
     1711        ENDIF
     1712
     1713        status = nf90_inq_dimid(ncidt, "LATU", dimid)
     1714        status = nf90_inquire_dimension(ncidt, dimid, namedim, lendim)
     1715        IF (lendim /= jjp1) THEN
     1716          abort_message = 'dimension LATU different from jjp1 in T.nc'
     1717          CALL abort_gcm(modname, abort_message, 1)
     1718        ENDIF
     1719
     1720      endif
     1721
     1722      ! Humidite
     1723      IF (guide_Q) THEN
     1724        rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
     1725        IF (rcode/=nf90_noerr) THEN
     1726          abort_message = 'Nudging: error -> no file hur.nc'
     1727          CALL abort_gcm(modname, abort_message, 1)
     1728        ENDIF
     1729        rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
     1730        IF (rcode/=nf90_noerr) THEN
     1731          abort_message = 'Nudging: error -> no RH variable in file hur.nc'
     1732          CALL abort_gcm(modname, abort_message, 1)
     1733        ENDIF
     1734        WRITE(*, *) trim(modname) // ' ncidQ,varidQ', ncidQ, varidQ
     1735        IF (ncidpl==-99) ncidpl = ncidQ
     1736
     1737        status = nf90_inq_dimid(ncidQ, "LONV", dimid)
     1738        status = nf90_inquire_dimension(ncidQ, dimid, namedim, lendim)
     1739        IF (lendim /= iip1) THEN
     1740          abort_message = 'dimension LONV different from iip1 in hur.nc'
     1741          CALL abort_gcm(modname, abort_message, 1)
     1742        ENDIF
     1743
     1744        status = nf90_inq_dimid(ncidQ, "LATU", dimid)
     1745        status = nf90_inquire_dimension(ncidQ, dimid, namedim, lendim)
     1746        IF (lendim /= jjp1) THEN
     1747          abort_message = 'dimension LATU different from jjp1 in hur.nc'
     1748          CALL abort_gcm(modname, abort_message, 1)
     1749        ENDIF
     1750
     1751      endif
     1752      ! Pression de surface
     1753      IF ((guide_P).OR.(guide_plevs==1)) THEN
     1754        rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
     1755        IF (rcode/=nf90_noerr) THEN
     1756          abort_message = 'Nudging: error -> no file ps.nc'
     1757          CALL abort_gcm(modname, abort_message, 1)
     1758        ENDIF
     1759        rcode = nf90_inq_varid(ncidps, 'SP', varidps)
     1760        IF (rcode/=nf90_noerr) THEN
     1761          abort_message = 'Nudging: error -> no SP variable in file ps.nc'
     1762          CALL abort_gcm(modname, abort_message, 1)
     1763        ENDIF
     1764        WRITE(*, *) trim(modname) // ' ncidps,varidps', ncidps, varidps
     1765      endif
     1766      ! Coordonnee verticale
     1767      IF (guide_plevs==0) THEN
     1768        rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
     1769        IF (rcode/=0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
     1770        WRITE(*, *) trim(modname) // ' ncidpl,varidpl', ncidpl, varidpl
     1771      endif
     1772      ! Coefs ap, bp pour calcul de la pression aux differents niveaux
     1773      IF (guide_plevs==1) THEN
     1774        status = nf90_put_var(ncidpl, varidap, apnc, [1], [nlevnc])
     1775        status = nf90_put_var(ncidpl, varidbp, bpnc, [1], [nlevnc])
     1776      ELSEIF (guide_plevs==0) THEN
     1777        status = nf90_put_var(ncidpl, varidpl, apnc, [1], [nlevnc])
     1778        !FC Pour les corrections la pression est deja en Pascals on commente la ligne ci-dessous
     1779        IF(convert_Pa) apnc = apnc * 100.! conversion en Pascals
     1780        bpnc(:) = 0.
     1781      ENDIF
     1782      first = .FALSE.
     1783    ENDIF ! (first)
     1784
     1785    ! -----------------------------------------------------------------
     1786    !   lecture des champs u, v, T, Q, ps
     1787    ! -----------------------------------------------------------------
     1788
     1789    !  dimensions pour les champs scalaires et le vent zonal
     1790    start(1) = 1
     1791    start(2) = jjb_u
     1792    start(3) = 1
     1793    start(4) = timestep
     1794
     1795    count(1) = iip1
     1796    count(2) = jjnb_u
     1797    count(3) = nlevnc
     1798    count(4) = 1
     1799
     1800    IF (invert_y) start(2) = jjp1 - jje_u + 1
     1801    ! Pression
     1802    IF (guide_plevs==2) THEN
     1803      status = nf90_put_var(ncidp, varidp, pnat2, start, count)
     1804      IF (invert_y) THEN
     1805        !           PRINT*,"Invertion impossible actuellement"
     1806        !           CALL abort_gcm(modname,abort_message,1)
     1807        CALL invert_lat(iip1, jjnb_u, nlevnc, pnat2)
     1808      ENDIF
     1809    endif
     1810
     1811    !  Vent zonal
     1812    IF (guide_u) THEN
     1813      status = nf90_put_var(ncidu, varidu, unat2, start, count)
     1814      IF (invert_y) THEN
     1815        !           PRINT*,"Invertion impossible actuellement"
     1816        !           CALL abort_gcm(modname,abort_message,1)
     1817        CALL invert_lat(iip1, jjnb_u, nlevnc, unat2)
     1818      ENDIF
     1819
     1820    endif
     1821
     1822
     1823    !  Temperature
     1824    IF (guide_T) THEN
     1825      status = nf90_put_var(ncidt, varidt, tnat2, start, count)
     1826      IF (invert_y) THEN
     1827        !           PRINT*,"Invertion impossible actuellement"
     1828        !           CALL abort_gcm(modname,abort_message,1)
     1829        CALL invert_lat(iip1, jjnb_u, nlevnc, tnat2)
     1830      ENDIF
     1831    endif
     1832
     1833    !  Humidite
     1834    IF (guide_Q) THEN
     1835      status = nf90_put_var(ncidQ, varidQ, qnat2, start, count)
     1836      IF (invert_y) THEN
     1837        !           PRINT*,"Invertion impossible actuellement"
     1838        !           CALL abort_gcm(modname,abort_message,1)
     1839        CALL invert_lat(iip1, jjnb_u, nlevnc, qnat2)
     1840      ENDIF
     1841
     1842    endif
     1843
     1844    !  Vent meridien
     1845    IF (guide_v) THEN
     1846      start(2) = jjb_v
     1847      count(2) = jjnb_v
     1848      IF (invert_y) start(2) = jjm - jje_v + 1
     1849
     1850      status = nf90_put_var(ncidv, varidv, vnat2, start, count)
     1851      IF (invert_y) THEN
     1852        !           PRINT*,"Invertion impossible actuellement"
     1853        !           CALL abort_gcm(modname,abort_message,1)
     1854        CALL invert_lat(iip1, jjnb_v, nlevnc, vnat2)
     1855      ENDIF
     1856    endif
     1857
     1858    !  Pression de surface
     1859    IF ((guide_P).OR.(guide_plevs==1))  THEN
     1860      start(2) = jjb_u
     1861      start(3) = timestep
     1862      start(4) = 0
     1863      count(2) = jjnb_u
     1864      count(3) = 1
     1865      count(4) = 0
     1866      IF (invert_y) start(2) = jjp1 - jje_u + 1
     1867      status = nf90_put_var(ncidps, varidps, psnat2, start, count)
     1868      IF (invert_y) THEN
     1869        !           PRINT*,"Invertion impossible actuellement"
     1870        !           CALL abort_gcm(modname,abort_message,1)
     1871        CALL invert_lat(iip1, jjnb_u, 1, psnat2)
     1872      ENDIF
     1873    endif
    18881874
    18891875  END SUBROUTINE guide_read
    18901876
    1891 !=======================================================================
     1877  !=======================================================================
    18921878  SUBROUTINE guide_read2D(timestep)
    18931879
    … …  
    18971883    include "paramet.h"
    18981884
    1899     INTEGER, INTENT(IN)   :: timestep
    1900 
    1901     LOGICAL, SAVE         :: first=.TRUE.
    1902 ! Identification fichiers et variables NetCDF:
    1903     INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
    1904     INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
    1905     INTEGER               :: ncidpl,varidpl,varidap,varidbp
    1906 ! Variables auxiliaires NetCDF:
    1907     INTEGER, DIMENSION(4) :: start,count
    1908     INTEGER               :: status,rcode
    1909 ! Variables for 3D extension:
    1910     REAL, DIMENSION (jjb_u:jje_u,llm) :: zu
    1911     REAL, DIMENSION (jjb_v:jje_v,llm) :: zv
    1912     INTEGER               :: i
    1913     CHARACTER (len = 80)   :: abort_message
    1914     CHARACTER (len = 20)   :: modname = 'guide_read2D'
    1915     abort_message='pb in guide_read2D'
    1916 
    1917 ! -----------------------------------------------------------------
    1918 ! Premier appel: initialisation de la lecture des fichiers
    1919 ! -----------------------------------------------------------------
    1920     if (first) THEN
    1921          ncidpl=-99
    1922          WRITE(*,*)trim(modname)//' : opening nudging files '
    1923 ! Ap et Bp si niveaux de pression hybrides
    1924          if (guide_plevs==1) THEN
    1925            WRITE(*,*)trim(modname)//' Reading nudging on model levels'
    1926            rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
    1927            IF (rcode/=nf90_noerr) THEN
    1928              abort_message='Nudging: error -> no file apbp.nc'
    1929            CALL abort_gcm(modname,abort_message,1)
    1930            ENDIF
    1931            rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
    1932            IF (rcode/=nf90_noerr) THEN
    1933              abort_message='Nudging: error -> no AP variable in file apbp.nc'
    1934            CALL abort_gcm(modname,abort_message,1)
    1935            ENDIF
    1936            rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
    1937            IF (rcode/=nf90_noerr) THEN
    1938              abort_message='Nudging: error -> no BP variable in file apbp.nc'
    1939              CALL abort_gcm(modname,abort_message,1)
    1940            ENDIF
    1941            WRITE(*,*)trim(modname)//'ncidpl,varidap',ncidpl,varidap
    1942          endif
    1943 ! Pression
    1944          if (guide_plevs==2) THEN
    1945            rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
    1946            IF (rcode/=nf90_noerr) THEN
    1947              abort_message='Nudging: error -> no file P.nc'
    1948              CALL abort_gcm(modname,abort_message,1)
    1949            ENDIF
    1950            rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
    1951            IF (rcode/=nf90_noerr) THEN
    1952              abort_message='Nudging: error -> no PRES variable in file P.nc'
    1953              CALL abort_gcm(modname,abort_message,1)
    1954            ENDIF
    1955            WRITE(*,*)trim(modname)//' ncidp,varidp',ncidp,varidp
    1956            if (ncidpl==-99) ncidpl=ncidp
    1957          endif
    1958 ! Vent zonal
    1959          if (guide_u) THEN
    1960            rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
    1961            IF (rcode/=nf90_noerr) THEN
    1962              abort_message='Nudging: error -> no file u.nc'
    1963              CALL abort_gcm(modname,abort_message,1)
    1964            ENDIF
    1965            rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
    1966            IF (rcode/=nf90_noerr) THEN
    1967              abort_message='Nudging: error -> no UWND variable in file u.nc'
    1968              CALL abort_gcm(modname,abort_message,1)
    1969            ENDIF
    1970            WRITE(*,*)trim(modname)//' ncidu,varidu',ncidu,varidu
    1971            if (ncidpl==-99) ncidpl=ncidu
    1972          endif
    1973 
    1974 ! Vent meridien
    1975          if (guide_v) THEN
    1976            rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
    1977            IF (rcode/=nf90_noerr) THEN
    1978              abort_message='Nudging: error -> no file v.nc'
    1979              CALL abort_gcm(modname,abort_message,1)
    1980            ENDIF
    1981            rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
    1982            IF (rcode/=nf90_noerr) THEN
    1983              abort_message='Nudging: error -> no VWND variable in file v.nc'
    1984              CALL abort_gcm(modname,abort_message,1)
    1985            ENDIF
    1986            WRITE(*,*)trim(modname)//' ncidv,varidv',ncidv,varidv
    1987            if (ncidpl==-99) ncidpl=ncidv
    1988         endif
    1989 ! Temperature
    1990          if (guide_T) THEN
    1991            rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
    1992            IF (rcode/=nf90_noerr) THEN
    1993              abort_message='Nudging: error -> no file T.nc'
    1994              CALL abort_gcm(modname,abort_message,1)
    1995            ENDIF
    1996            rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
    1997            IF (rcode/=nf90_noerr) THEN
    1998              abort_message='Nudging: error -> no AIR variable in file T.nc'
    1999              CALL abort_gcm(modname,abort_message,1)
    2000            ENDIF
    2001            WRITE(*,*)trim(modname)//' ncidT,varidT',ncidt,varidt
    2002            if (ncidpl==-99) ncidpl=ncidt
    2003          endif
    2004 ! Humidite
    2005          if (guide_Q) THEN
    2006            rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
    2007            IF (rcode/=nf90_noerr) THEN
    2008              abort_message='Nudging: error -> no file hur.nc'
    2009              CALL abort_gcm(modname,abort_message,1)
    2010            ENDIF
    2011            rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
    2012            IF (rcode/=nf90_noerr) THEN
    2013              abort_message='Nudging: error -> no RH,variable in file hur.nc'
    2014              CALL abort_gcm(modname,abort_message,1)
    2015            ENDIF
    2016            WRITE(*,*)trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
    2017            if (ncidpl==-99) ncidpl=ncidQ
    2018          endif
    2019 ! Pression de surface
    2020          if ((guide_P).OR.(guide_plevs==1)) THEN
    2021            rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
    2022            IF (rcode/=nf90_noerr) THEN
    2023              abort_message='Nudging: error -> no file ps.nc'
    2024              CALL abort_gcm(modname,abort_message,1)
    2025            ENDIF
    2026            rcode = nf90_inq_varid(ncidps, 'SP', varidps)
    2027            IF (rcode/=nf90_noerr) THEN
    2028              abort_message='Nudging: error -> no SP variable in file ps.nc'
    2029              CALL abort_gcm(modname,abort_message,1)
    2030            ENDIF
    2031            WRITE(*,*)trim(modname)//' ncidps,varidps',ncidps,varidps
    2032          endif
    2033 ! Coordonnee verticale
    2034          if (guide_plevs==0) THEN
    2035            rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
    2036            IF (rcode/=0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
    2037            WRITE(*,*)trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
    2038          endif
    2039 ! Coefs ap, bp pour calcul de la pression aux differents niveaux
    2040          if (guide_plevs==1) THEN
    2041              status=nf90_put_var(ncidpl,varidap,apnc,[1],[nlevnc])
    2042              status=nf90_put_var(ncidpl,varidbp,bpnc,[1],[nlevnc])
    2043          elseif (guide_plevs==0) THEN
    2044              status=nf90_put_var(ncidpl,varidpl,apnc,[1],[nlevnc])
    2045              apnc=apnc*100.! conversion en Pascals
    2046              bpnc(:)=0.
    2047          endif
    2048          first=.FALSE.
    2049      endif ! (first)
    2050 
    2051 ! -----------------------------------------------------------------
    2052 !   lecture des champs u, v, T, Q, ps
    2053 ! -----------------------------------------------------------------
    2054 
    2055 !  dimensions pour les champs scalaires et le vent zonal
    2056      start(1)=1
    2057      start(2)=jjb_u
    2058      start(3)=1
    2059      start(4)=timestep
    2060 
    2061      count(1)=1
    2062      count(2)=jjnb_u
    2063      count(3)=nlevnc
    2064      count(4)=1
    2065 
    2066      IF (invert_y) start(2)=jjp1-jje_u+1
    2067 !  Pression
    2068      if (guide_plevs==2) THEN
    2069          status=nf90_put_var(ncidp,varidp,zu,start,count)
    2070          DO i=1,iip1
    2071              pnat2(i,:,:)=zu(:,:)
    2072          ENDDO
    2073 
    2074          IF (invert_y) THEN
    2075 !           PRINT*,"Invertion impossible actuellement"
    2076 !           CALL abort_gcm(modname,abort_message,1)
    2077            CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
    2078          ENDIF
    2079      endif
    2080 !  Vent zonal
    2081      if (guide_u) THEN
    2082          status=nf90_put_var(ncidu,varidu,zu,start,count)
    2083          DO i=1,iip1
    2084              unat2(i,:,:)=zu(:,:)
    2085          ENDDO
    2086 
    2087          IF (invert_y) THEN
    2088 !           PRINT*,"Invertion impossible actuellement"
    2089 !           CALL abort_gcm(modname,abort_message,1)
    2090            CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
    2091          ENDIF
    2092      endif
    2093 
    2094 
    2095 !  Temperature
    2096      if (guide_T) THEN
    2097          status=nf90_put_var(ncidt,varidt,zu,start,count)
    2098          DO i=1,iip1
    2099              tnat2(i,:,:)=zu(:,:)
    2100          ENDDO
    2101 
    2102          IF (invert_y) THEN
    2103 !           PRINT*,"Invertion impossible actuellement"
    2104 !           CALL abort_gcm(modname,abort_message,1)
    2105            CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
    2106          ENDIF
    2107      endif
    2108 
    2109 !  Humidite
    2110      if (guide_Q) THEN
    2111          status=nf90_put_var(ncidQ,varidQ,zu,start,count)
    2112          DO i=1,iip1
    2113              qnat2(i,:,:)=zu(:,:)
    2114          ENDDO
    2115          
    2116          IF (invert_y) THEN
    2117 !           PRINT*,"Invertion impossible actuellement"
    2118 !           CALL abort_gcm(modname,abort_message,1)
    2119            CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
    2120          ENDIF
    2121      endif
    2122 
    2123 !  Vent meridien
    2124      if (guide_v) THEN
    2125          start(2)=jjb_v
    2126          count(2)=jjnb_v
    2127          IF (invert_y) start(2)=jjm-jje_v+1
    2128          status=nf90_put_var(ncidv,varidv,zv,start,count)
    2129          DO i=1,iip1
    2130              vnat2(i,:,:)=zv(:,:)
    2131          ENDDO
    2132 
    2133          IF (invert_y) THEN
    2134  
    2135 !           PRINT*,"Invertion impossible actuellement"
    2136 !           CALL abort_gcm(modname,abort_message,1)
    2137            CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
    2138          ENDIF
    2139      endif
    2140 
    2141 !  Pression de surface
    2142      if ((guide_P).OR.(guide_plevs==1))  THEN
    2143          start(2)=jjb_u
    2144          start(3)=timestep
    2145          start(4)=0
    2146          count(2)=jjnb_u
    2147          count(3)=1
    2148          count(4)=0
    2149          IF (invert_y) start(2)=jjp1-jje_u+1
    2150          status=nf90_put_var(ncidps,varidps,zu(:,1),start,count)
    2151          DO i=1,iip1
    2152              psnat2(i,:)=zu(:,1)
    2153          ENDDO
    2154 
    2155          IF (invert_y) THEN
    2156 !           PRINT*,"Invertion impossible actuellement"
    2157 !           CALL abort_gcm(modname,abort_message,1)
    2158            CALL invert_lat(iip1,jjnb_u,1,psnat2)
    2159          ENDIF
    2160      endif
     1885    INTEGER, INTENT(IN) :: timestep
     1886
     1887    LOGICAL, SAVE :: first = .TRUE.
     1888    ! Identification fichiers et variables NetCDF:
     1889    INTEGER, SAVE :: ncidu, varidu, ncidv, varidv, ncidp, varidp
     1890    INTEGER, SAVE :: ncidQ, varidQ, ncidt, varidt, ncidps, varidps
     1891    INTEGER :: ncidpl, varidpl, varidap, varidbp
     1892    ! Variables auxiliaires NetCDF:
     1893    INTEGER, DIMENSION(4) :: start, count
     1894    INTEGER :: status, rcode
     1895    ! Variables for 3D extension:
     1896    REAL, DIMENSION (jjb_u:jje_u, llm) :: zu
     1897    REAL, DIMENSION (jjb_v:jje_v, llm) :: zv
     1898    INTEGER :: i
     1899    CHARACTER (len = 80) :: abort_message
     1900    CHARACTER (len = 20) :: modname = 'guide_read2D'
     1901    abort_message = 'pb in guide_read2D'
     1902
     1903    ! -----------------------------------------------------------------
     1904    ! Premier appel: initialisation de la lecture des fichiers
     1905    ! -----------------------------------------------------------------
     1906    IF (first) THEN
     1907      ncidpl = -99
     1908      WRITE(*, *)trim(modname) // ' : opening nudging files '
     1909      ! Ap et Bp si niveaux de pression hybrides
     1910      IF (guide_plevs==1) THEN
     1911        WRITE(*, *)trim(modname) // ' Reading nudging on model levels'
     1912        rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
     1913        IF (rcode/=nf90_noerr) THEN
     1914          abort_message = 'Nudging: error -> no file apbp.nc'
     1915          CALL abort_gcm(modname, abort_message, 1)
     1916        ENDIF
     1917        rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
     1918        IF (rcode/=nf90_noerr) THEN
     1919          abort_message = 'Nudging: error -> no AP variable in file apbp.nc'
     1920          CALL abort_gcm(modname, abort_message, 1)
     1921        ENDIF
     1922        rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
     1923        IF (rcode/=nf90_noerr) THEN
     1924          abort_message = 'Nudging: error -> no BP variable in file apbp.nc'
     1925          CALL abort_gcm(modname, abort_message, 1)
     1926        ENDIF
     1927        WRITE(*, *)trim(modname) // 'ncidpl,varidap', ncidpl, varidap
     1928      endif
     1929      ! Pression
     1930      IF (guide_plevs==2) THEN
     1931        rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
     1932        IF (rcode/=nf90_noerr) THEN
     1933          abort_message = 'Nudging: error -> no file P.nc'
     1934          CALL abort_gcm(modname, abort_message, 1)
     1935        ENDIF
     1936        rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
     1937        IF (rcode/=nf90_noerr) THEN
     1938          abort_message = 'Nudging: error -> no PRES variable in file P.nc'
     1939          CALL abort_gcm(modname, abort_message, 1)
     1940        ENDIF
     1941        WRITE(*, *)trim(modname) // ' ncidp,varidp', ncidp, varidp
     1942        IF (ncidpl==-99) ncidpl = ncidp
     1943      endif
     1944      ! Vent zonal
     1945      IF (guide_u) THEN
     1946        rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
     1947        IF (rcode/=nf90_noerr) THEN
     1948          abort_message = 'Nudging: error -> no file u.nc'
     1949          CALL abort_gcm(modname, abort_message, 1)
     1950        ENDIF
     1951        rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
     1952        IF (rcode/=nf90_noerr) THEN
     1953          abort_message = 'Nudging: error -> no UWND variable in file u.nc'
     1954          CALL abort_gcm(modname, abort_message, 1)
     1955        ENDIF
     1956        WRITE(*, *)trim(modname) // ' ncidu,varidu', ncidu, varidu
     1957        IF (ncidpl==-99) ncidpl = ncidu
     1958      endif
     1959
     1960      ! Vent meridien
     1961      IF (guide_v) THEN
     1962        rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
     1963        IF (rcode/=nf90_noerr) THEN
     1964          abort_message = 'Nudging: error -> no file v.nc'
     1965          CALL abort_gcm(modname, abort_message, 1)
     1966        ENDIF
     1967        rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
     1968        IF (rcode/=nf90_noerr) THEN
     1969          abort_message = 'Nudging: error -> no VWND variable in file v.nc'
     1970          CALL abort_gcm(modname, abort_message, 1)
     1971        ENDIF
     1972        WRITE(*, *)trim(modname) // ' ncidv,varidv', ncidv, varidv
     1973        IF (ncidpl==-99) ncidpl = ncidv
     1974      endif
     1975      ! Temperature
     1976      IF (guide_T) THEN
     1977        rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
     1978        IF (rcode/=nf90_noerr) THEN
     1979          abort_message = 'Nudging: error -> no file T.nc'
     1980          CALL abort_gcm(modname, abort_message, 1)
     1981        ENDIF
     1982        rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
     1983        IF (rcode/=nf90_noerr) THEN
     1984          abort_message = 'Nudging: error -> no AIR variable in file T.nc'
     1985          CALL abort_gcm(modname, abort_message, 1)
     1986        ENDIF
     1987        WRITE(*, *)trim(modname) // ' ncidT,varidT', ncidt, varidt
     1988        IF (ncidpl==-99) ncidpl = ncidt
     1989      endif
     1990      ! Humidite
     1991      IF (guide_Q) THEN
     1992        rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
     1993        IF (rcode/=nf90_noerr) THEN
     1994          abort_message = 'Nudging: error -> no file hur.nc'
     1995          CALL abort_gcm(modname, abort_message, 1)
     1996        ENDIF
     1997        rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
     1998        IF (rcode/=nf90_noerr) THEN
     1999          abort_message = 'Nudging: error -> no RH,variable in file hur.nc'
     2000          CALL abort_gcm(modname, abort_message, 1)
     2001        ENDIF
     2002        WRITE(*, *)trim(modname) // ' ncidQ,varidQ', ncidQ, varidQ
     2003        IF (ncidpl==-99) ncidpl = ncidQ
     2004      endif
     2005      ! Pression de surface
     2006      IF ((guide_P).OR.(guide_plevs==1)) THEN
     2007        rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
     2008        IF (rcode/=nf90_noerr) THEN
     2009          abort_message = 'Nudging: error -> no file ps.nc'
     2010          CALL abort_gcm(modname, abort_message, 1)
     2011        ENDIF
     2012        rcode = nf90_inq_varid(ncidps, 'SP', varidps)
     2013        IF (rcode/=nf90_noerr) THEN
     2014          abort_message = 'Nudging: error -> no SP variable in file ps.nc'
     2015          CALL abort_gcm(modname, abort_message, 1)
     2016        ENDIF
     2017        WRITE(*, *)trim(modname) // ' ncidps,varidps', ncidps, varidps
     2018      endif
     2019      ! Coordonnee verticale
     2020      IF (guide_plevs==0) THEN
     2021        rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
     2022        IF (rcode/=0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
     2023        WRITE(*, *)trim(modname) // ' ncidpl,varidpl', ncidpl, varidpl
     2024      endif
     2025      ! Coefs ap, bp pour calcul de la pression aux differents niveaux
     2026      IF (guide_plevs==1) THEN
     2027        status = nf90_put_var(ncidpl, varidap, apnc, [1], [nlevnc])
     2028        status = nf90_put_var(ncidpl, varidbp, bpnc, [1], [nlevnc])
     2029      elseif (guide_plevs==0) THEN
     2030        status = nf90_put_var(ncidpl, varidpl, apnc, [1], [nlevnc])
     2031        apnc = apnc * 100.! conversion en Pascals
     2032        bpnc(:) = 0.
     2033      endif
     2034      first = .FALSE.
     2035    endif ! (first)
     2036
     2037    ! -----------------------------------------------------------------
     2038    !   lecture des champs u, v, T, Q, ps
     2039    ! -----------------------------------------------------------------
     2040
     2041    !  dimensions pour les champs scalaires et le vent zonal
     2042    start(1) = 1
     2043    start(2) = jjb_u
     2044    start(3) = 1
     2045    start(4) = timestep
     2046
     2047    count(1) = 1
     2048    count(2) = jjnb_u
     2049    count(3) = nlevnc
     2050    count(4) = 1
     2051
     2052    IF (invert_y) start(2) = jjp1 - jje_u + 1
     2053    !  Pression
     2054    IF (guide_plevs==2) THEN
     2055      status = nf90_put_var(ncidp, varidp, zu, start, count)
     2056      DO i = 1, iip1
     2057        pnat2(i, :, :) = zu(:, :)
     2058      ENDDO
     2059
     2060      IF (invert_y) THEN
     2061        !           PRINT*,"Invertion impossible actuellement"
     2062        !           CALL abort_gcm(modname,abort_message,1)
     2063        CALL invert_lat(iip1, jjnb_u, nlevnc, pnat2)
     2064      ENDIF
     2065    endif
     2066    !  Vent zonal
     2067    IF (guide_u) THEN
     2068      status = nf90_put_var(ncidu, varidu, zu, start, count)
     2069      DO i = 1, iip1
     2070        unat2(i, :, :) = zu(:, :)
     2071      ENDDO
     2072
     2073      IF (invert_y) THEN
     2074        !           PRINT*,"Invertion impossible actuellement"
     2075        !           CALL abort_gcm(modname,abort_message,1)
     2076        CALL invert_lat(iip1, jjnb_u, nlevnc, unat2)
     2077      ENDIF
     2078    endif
     2079
     2080
     2081    !  Temperature
     2082    IF (guide_T) THEN
     2083      status = nf90_put_var(ncidt, varidt, zu, start, count)
     2084      DO i = 1, iip1
     2085        tnat2(i, :, :) = zu(:, :)
     2086      ENDDO
     2087
     2088      IF (invert_y) THEN
     2089        !           PRINT*,"Invertion impossible actuellement"
     2090        !           CALL abort_gcm(modname,abort_message,1)
     2091        CALL invert_lat(iip1, jjnb_u, nlevnc, tnat2)
     2092      ENDIF
     2093    endif
     2094
     2095    !  Humidite
     2096    IF (guide_Q) THEN
     2097      status = nf90_put_var(ncidQ, varidQ, zu, start, count)
     2098      DO i = 1, iip1
     2099        qnat2(i, :, :) = zu(:, :)
     2100      ENDDO
     2101
     2102      IF (invert_y) THEN
     2103        !           PRINT*,"Invertion impossible actuellement"
     2104        !           CALL abort_gcm(modname,abort_message,1)
     2105        CALL invert_lat(iip1, jjnb_u, nlevnc, qnat2)
     2106      ENDIF
     2107    endif
     2108
     2109    !  Vent meridien
     2110    IF (guide_v) THEN
     2111      start(2) = jjb_v
     2112      count(2) = jjnb_v
     2113      IF (invert_y) start(2) = jjm - jje_v + 1
     2114      status = nf90_put_var(ncidv, varidv, zv, start, count)
     2115      DO i = 1, iip1
     2116        vnat2(i, :, :) = zv(:, :)
     2117      ENDDO
     2118
     2119      IF (invert_y) THEN
     2120
     2121        !           PRINT*,"Invertion impossible actuellement"
     2122        !           CALL abort_gcm(modname,abort_message,1)
     2123        CALL invert_lat(iip1, jjnb_v, nlevnc, vnat2)
     2124      ENDIF
     2125    endif
     2126
     2127    !  Pression de surface
     2128    IF ((guide_P).OR.(guide_plevs==1))  THEN
     2129      start(2) = jjb_u
     2130      start(3) = timestep
     2131      start(4) = 0
     2132      count(2) = jjnb_u
     2133      count(3) = 1
     2134      count(4) = 0
     2135      IF (invert_y) start(2) = jjp1 - jje_u + 1
     2136      status = nf90_put_var(ncidps, varidps, zu(:, 1), start, count)
     2137      DO i = 1, iip1
     2138        psnat2(i, :) = zu(:, 1)
     2139      ENDDO
     2140
     2141      IF (invert_y) THEN
     2142        !           PRINT*,"Invertion impossible actuellement"
     2143        !           CALL abort_gcm(modname,abort_message,1)
     2144        CALL invert_lat(iip1, jjnb_u, 1, psnat2)
     2145      ENDIF
     2146    endif
    21612147
    21622148  END SUBROUTINE guide_read2D
    2163  
    2164 !=======================================================================
    2165   SUBROUTINE guide_out(varname,hsize,vsize,field_loc,factt)
     2149
     2150  !=======================================================================
     2151  SUBROUTINE guide_out(varname, hsize, vsize, field_loc, factt)
    21662152    USE parallel_lmdz
    21672153    USE mod_hallo, ONLY: gather_field_u, gather_field_v
    21682154    USE comconst_mod, ONLY: pi
    21692155    USE comvert_mod, ONLY: presnivs
    2170     use netcdf95, ONLY: nf95_def_var, nf95_put_var
     2156    USE netcdf95, ONLY: nf95_def_var, nf95_put_var
    21712157
    21722158    IMPLICIT NONE
    … …  
    21752161    INCLUDE "paramet.h"
    21762162    INCLUDE "comgeom2.h"
    2177    
     2163
    21782164    ! Variables entree
    2179     CHARACTER*(*), INTENT(IN)                      :: varname
    2180     INTEGER,   INTENT (IN)                         :: hsize,vsize
    2181 !   REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field_loc
    2182     REAL, DIMENSION (:,:), INTENT(IN) :: field_loc
     2165    CHARACTER*(*), INTENT(IN) :: varname
     2166    INTEGER, INTENT (IN) :: hsize, vsize
     2167    !   REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field_loc
     2168    REAL, DIMENSION (:, :), INTENT(IN) :: field_loc
    21832169    REAL factt
    21842170
    21852171    ! Variables locales
    2186     INTEGER, SAVE :: timestep=0
     2172    INTEGER, SAVE :: timestep = 0
    21872173    ! Identites fichier netcdf
    2188     INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
    2189     INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
    2190     INTEGER       :: vid_au,vid_av, varid_alpha_t, varid_alpha_q
     2174    INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
     2175    INTEGER :: vid_lonu, vid_lonv, vid_latu, vid_latv, vid_cu, vid_cv, vid_lev
     2176    INTEGER :: vid_au, vid_av, varid_alpha_t, varid_alpha_q
    21912177    INTEGER, DIMENSION (3) :: dim3
    2192     INTEGER, DIMENSION (4) :: dim4,count,start
    2193     INTEGER                :: ierr, varid,l
    2194     REAL zu(ip1jmp1),zv(ip1jm), zt(iip1, jjp1), zq(iip1, jjp1)
    2195     REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: field_glo
    2196     CHARACTER(LEN=20),PARAMETER :: modname="guide_out"
    2197    
    2198 !$OMP MASTER
    2199     ALLOCATE(field_glo(iip1,hsize,vsize))
    2200 !$OMP END MASTER
    2201 !$OMP BARRIER
    2202 
    2203 !    WRITE(*,*)trim(modname)//' after allocation ',hsize,vsize
     2178    INTEGER, DIMENSION (4) :: dim4, count, start
     2179    INTEGER :: ierr, varid, l
     2180    REAL zu(ip1jmp1), zv(ip1jm), zt(iip1, jjp1), zq(iip1, jjp1)
     2181    REAL, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: field_glo
     2182    CHARACTER(LEN = 20), PARAMETER :: modname = "guide_out"
     2183
     2184    !$OMP MASTER
     2185    ALLOCATE(field_glo(iip1, hsize, vsize))
     2186    !$OMP END MASTER
     2187    !$OMP BARRIER
     2188
     2189    !    WRITE(*,*)trim(modname)//' after allocation ',hsize,vsize
    22042190
    22052191    IF (hsize==jjp1) THEN
    2206         CALL gather_field_u(field_loc,field_glo,vsize)
     2192      CALL gather_field_u(field_loc, field_glo, vsize)
    22072193    ELSE IF (hsize==jjm) THEN
    2208        CALL gather_field_v(field_loc,field_glo, vsize)
    2209     ENDIF
    2210 
    2211 !    WRITE(*,*)trim(modname)//' after gather '
    2212     CALL Gather_field_u(alpha_u,zu,1)
    2213     CALL Gather_field_u(alpha_t,zt,1)
    2214     CALL Gather_field_u(alpha_q,zq,1)
    2215     CALL Gather_field_v(alpha_v,zv,1)
     2194      CALL gather_field_v(field_loc, field_glo, vsize)
     2195    ENDIF
     2196
     2197    !    WRITE(*,*)trim(modname)//' after gather '
     2198    CALL Gather_field_u(alpha_u, zu, 1)
     2199    CALL Gather_field_u(alpha_t, zt, 1)
     2200    CALL Gather_field_u(alpha_q, zq, 1)
     2201    CALL Gather_field_v(alpha_v, zv, 1)
    22162202
    22172203    IF (mpi_rank >  0) THEN
    2218 !$OMP MASTER
    2219        DEALLOCATE(field_glo)
    2220 !$OMP END MASTER
    2221 !$OMP BARRIER
    2222 
    2223        RETURN
    2224     ENDIF
    2225    
    2226 !$OMP MASTER
     2204      !$OMP MASTER
     2205      DEALLOCATE(field_glo)
     2206      !$OMP END MASTER
     2207      !$OMP BARRIER
     2208
     2209      RETURN
     2210    ENDIF
     2211
     2212    !$OMP MASTER
    22272213    IF (timestep==0) THEN
    2228 ! ----------------------------------------------
    2229 ! initialisation fichier de sortie
    2230 ! ----------------------------------------------
    2231 ! Ouverture du fichier
    2232         ierr=nf90_create("guide_ins.nc",IOR(nf90_clobber,nf90_64bit_offset),nid)
    2233 ! Definition des dimensions
    2234         ierr=nf90_def_dim(nid,"LONU",iip1,id_lonu)
    2235         ierr=nf90_def_dim(nid,"LONV",iip1,id_lonv)
    2236         ierr=nf90_def_dim(nid,"LATU",jjp1,id_latu)
    2237         ierr=nf90_def_dim(nid,"LATV",jjm,id_latv)
    2238         ierr=nf90_def_dim(nid,"LEVEL",llm,id_lev)
    2239         ierr=nf90_def_dim(nid,"TIME",nf90_unlimited,id_tim)
    2240 
    2241 ! Creation des variables dimensions
    2242         ierr=nf90_def_var(nid,"LONU",nf90_float,id_lonu,vid_lonu)
    2243         ierr=nf90_def_var(nid,"LONV",nf90_float,id_lonv,vid_lonv)
    2244         ierr=nf90_def_var(nid,"LATU",nf90_float,id_latu,vid_latu)
    2245         ierr=nf90_def_var(nid,"LATV",nf90_float,id_latv,vid_latv)
    2246         ierr=nf90_def_var(nid,"LEVEL",nf90_float,id_lev,vid_lev)
    2247         ierr=nf90_def_var(nid,"cu",nf90_float,(/id_lonu,id_latu/),vid_cu)
    2248         ierr=nf90_def_var(nid,"cv",nf90_float,(/id_lonv,id_latv/),vid_cv)
    2249         ierr=nf90_def_var(nid,"au",nf90_float,(/id_lonu,id_latu/),vid_au)
    2250         ierr=nf90_def_var(nid,"av",nf90_float,(/id_lonv,id_latv/),vid_av)
    2251         CALL nf95_def_var(nid, "alpha_T", nf90_float, (/id_lonv, id_latu/), &
    2252              varid_alpha_t)
    2253         CALL nf95_def_var(nid, "alpha_q", nf90_float, (/id_lonv, id_latu/), &
    2254              varid_alpha_q)
    2255        
    2256         ierr=nf90_enddef(nid)
    2257 
    2258 ! Enregistrement des variables dimensions
    2259         ierr = nf90_put_var(nid,vid_lonu,rlonu*180./pi)
    2260         ierr = nf90_put_var(nid,vid_lonv,rlonv*180./pi)
    2261         ierr = nf90_put_var(nid,vid_latu,rlatu*180./pi)
    2262         ierr = nf90_put_var(nid,vid_latv,rlatv*180./pi)
    2263         ierr = nf90_put_var(nid,vid_lev,presnivs)
    2264         ierr = nf90_put_var(nid,vid_cu,cu)
    2265         ierr = nf90_put_var(nid,vid_cv,cv)
    2266         ierr = nf90_put_var(nid,vid_au,zu)
    2267         ierr = nf90_put_var(nid,vid_av,zv)
    2268         CALL nf95_put_var(nid, varid_alpha_t, zt)
    2269         CALL nf95_put_var(nid, varid_alpha_q, zq)
    2270 ! --------------------------------------------------------------------
    2271 ! Création des variables sauvegardées
    2272 ! --------------------------------------------------------------------
    2273         ierr = nf90_redef(nid)
    2274 ! Pressure (GCM)
    2275         dim4=(/id_lonv,id_latu,id_lev,id_tim/)
    2276         ierr = nf90_def_var(nid,"SP",nf90_float,dim4,varid)
    2277 ! Surface pressure (guidage)
    2278         IF (guide_P) THEN
    2279             dim3=(/id_lonv,id_latu,id_tim/)
    2280             ierr = nf90_def_var(nid,"ps",nf90_float,dim3,varid)
    2281         ENDIF
    2282 ! Zonal wind
    2283         IF (guide_u) THEN
    2284             dim4=(/id_lonu,id_latu,id_lev,id_tim/)
    2285             ierr = nf90_def_var(nid,"u",nf90_float,dim4,varid)
    2286             ierr = nf90_def_var(nid,"ua",nf90_float,dim4,varid)
    2287             ierr = nf90_def_var(nid,"ucov",nf90_float,dim4,varid)
    2288         ENDIF
    2289 ! Merid. wind
    2290         IF (guide_v) THEN
    2291             dim4=(/id_lonv,id_latv,id_lev,id_tim/)
    2292             ierr = nf90_def_var(nid,"v",nf90_float,dim4,varid)
    2293             ierr = nf90_def_var(nid,"va",nf90_float,dim4,varid)
    2294             ierr = nf90_def_var(nid,"vcov",nf90_float,dim4,varid)
    2295         ENDIF
    2296 ! Pot. Temperature
    2297         IF (guide_T) THEN
    2298             dim4=(/id_lonv,id_latu,id_lev,id_tim/)
    2299             ierr = nf90_def_var(nid,"teta",nf90_float,dim4,varid)
    2300         ENDIF
    2301 ! Specific Humidity
    2302         IF (guide_Q) THEN
    2303             dim4=(/id_lonv,id_latu,id_lev,id_tim/)
    2304             ierr = nf90_def_var(nid,"q",nf90_float,dim4,varid)
    2305         ENDIF
    2306        
    2307         ierr = nf90_enddef(nid)
    2308         ierr = nf90_close(nid)
     2214      ! ----------------------------------------------
     2215      ! initialisation fichier de sortie
     2216      ! ----------------------------------------------
     2217      ! Ouverture du fichier
     2218      ierr = nf90_create("guide_ins.nc", IOR(nf90_clobber, nf90_64bit_offset), nid)
     2219      ! Definition des dimensions
     2220      ierr = nf90_def_dim(nid, "LONU", iip1, id_lonu)
     2221      ierr = nf90_def_dim(nid, "LONV", iip1, id_lonv)
     2222      ierr = nf90_def_dim(nid, "LATU", jjp1, id_latu)
     2223      ierr = nf90_def_dim(nid, "LATV", jjm, id_latv)
     2224      ierr = nf90_def_dim(nid, "LEVEL", llm, id_lev)
     2225      ierr = nf90_def_dim(nid, "TIME", nf90_unlimited, id_tim)
     2226
     2227      ! Creation des variables dimensions
     2228      ierr = nf90_def_var(nid, "LONU", nf90_float, id_lonu, vid_lonu)
     2229      ierr = nf90_def_var(nid, "LONV", nf90_float, id_lonv, vid_lonv)
     2230      ierr = nf90_def_var(nid, "LATU", nf90_float, id_latu, vid_latu)
     2231      ierr = nf90_def_var(nid, "LATV", nf90_float, id_latv, vid_latv)
     2232      ierr = nf90_def_var(nid, "LEVEL", nf90_float, id_lev, vid_lev)
     2233      ierr = nf90_def_var(nid, "cu", nf90_float, (/id_lonu, id_latu/), vid_cu)
     2234      ierr = nf90_def_var(nid, "cv", nf90_float, (/id_lonv, id_latv/), vid_cv)
     2235      ierr = nf90_def_var(nid, "au", nf90_float, (/id_lonu, id_latu/), vid_au)
     2236      ierr = nf90_def_var(nid, "av", nf90_float, (/id_lonv, id_latv/), vid_av)
     2237      CALL nf95_def_var(nid, "alpha_T", nf90_float, (/id_lonv, id_latu/), &
     2238              varid_alpha_t)
     2239      CALL nf95_def_var(nid, "alpha_q", nf90_float, (/id_lonv, id_latu/), &
     2240              varid_alpha_q)
     2241
     2242      ierr = nf90_enddef(nid)
     2243
     2244      ! Enregistrement des variables dimensions
     2245      ierr = nf90_put_var(nid, vid_lonu, rlonu * 180. / pi)
     2246      ierr = nf90_put_var(nid, vid_lonv, rlonv * 180. / pi)
     2247      ierr = nf90_put_var(nid, vid_latu, rlatu * 180. / pi)
     2248      ierr = nf90_put_var(nid, vid_latv, rlatv * 180. / pi)
     2249      ierr = nf90_put_var(nid, vid_lev, presnivs)
     2250      ierr = nf90_put_var(nid, vid_cu, cu)
     2251      ierr = nf90_put_var(nid, vid_cv, cv)
     2252      ierr = nf90_put_var(nid, vid_au, zu)
     2253      ierr = nf90_put_var(nid, vid_av, zv)
     2254      CALL nf95_put_var(nid, varid_alpha_t, zt)
     2255      CALL nf95_put_var(nid, varid_alpha_q, zq)
     2256      ! --------------------------------------------------------------------
     2257      ! Création des variables sauvegardées
     2258      ! --------------------------------------------------------------------
     2259      ierr = nf90_redef(nid)
     2260      ! Pressure (GCM)
     2261      dim4 = (/id_lonv, id_latu, id_lev, id_tim/)
     2262      ierr = nf90_def_var(nid, "SP", nf90_float, dim4, varid)
     2263      ! Surface pressure (guidage)
     2264      IF (guide_P) THEN
     2265        dim3 = (/id_lonv, id_latu, id_tim/)
     2266        ierr = nf90_def_var(nid, "ps", nf90_float, dim3, varid)
     2267      ENDIF
     2268      ! Zonal wind
     2269      IF (guide_u) THEN
     2270        dim4 = (/id_lonu, id_latu, id_lev, id_tim/)
     2271        ierr = nf90_def_var(nid, "u", nf90_float, dim4, varid)
     2272        ierr = nf90_def_var(nid, "ua", nf90_float, dim4, varid)
     2273        ierr = nf90_def_var(nid, "ucov", nf90_float, dim4, varid)
     2274      ENDIF
     2275      ! Merid. wind
     2276      IF (guide_v) THEN
     2277        dim4 = (/id_lonv, id_latv, id_lev, id_tim/)
     2278        ierr = nf90_def_var(nid, "v", nf90_float, dim4, varid)
     2279        ierr = nf90_def_var(nid, "va", nf90_float, dim4, varid)
     2280        ierr = nf90_def_var(nid, "vcov", nf90_float, dim4, varid)
     2281      ENDIF
     2282      ! Pot. Temperature
     2283      IF (guide_T) THEN
     2284        dim4 = (/id_lonv, id_latu, id_lev, id_tim/)
     2285        ierr = nf90_def_var(nid, "teta", nf90_float, dim4, varid)
     2286      ENDIF
     2287      ! Specific Humidity
     2288      IF (guide_Q) THEN
     2289        dim4 = (/id_lonv, id_latu, id_lev, id_tim/)
     2290        ierr = nf90_def_var(nid, "q", nf90_float, dim4, varid)
     2291      ENDIF
     2292
     2293      ierr = nf90_enddef(nid)
     2294      ierr = nf90_close(nid)
    23092295    ENDIF ! timestep=0
    23102296
    2311 ! --------------------------------------------------------------------
    2312 ! Enregistrement du champ
    2313 ! --------------------------------------------------------------------
    2314  
    2315     ierr=nf90_open("guide_ins.nc",nf90_write,nid)
    2316 
    2317     IF (varname=="SP") timestep=timestep+1
    2318 
    2319     ierr = nf90_inq_varid(nid,varname,varid)
     2297    ! --------------------------------------------------------------------
     2298    ! Enregistrement du champ
     2299    ! --------------------------------------------------------------------
     2300
     2301    ierr = nf90_open("guide_ins.nc", nf90_write, nid)
     2302
     2303    IF (varname=="SP") timestep = timestep + 1
     2304
     2305    ierr = nf90_inq_varid(nid, varname, varid)
    23202306    SELECT CASE (varname)
    2321     CASE ("SP","ps")
    2322         start=(/1,1,1,timestep/)
    2323         count=(/iip1,jjp1,llm,1/)
    2324     CASE ("v","va","vcov")
    2325         start=(/1,1,1,timestep/)
    2326         count=(/iip1,jjm,llm,1/)
     2307    CASE ("SP", "ps")
     2308      start = (/1, 1, 1, timestep/)
     2309      count = (/iip1, jjp1, llm, 1/)
     2310    CASE ("v", "va", "vcov")
     2311      start = (/1, 1, 1, timestep/)
     2312      count = (/iip1, jjm, llm, 1/)
    23272313    CASE DEFAULT
    2328         start=(/1,1,1,timestep/)
    2329         count=(/iip1,jjp1,llm,1/)
     2314      start = (/1, 1, 1, timestep/)
     2315      count = (/iip1, jjp1, llm, 1/)
    23302316    END SELECT
    23312317
    2332 !$OMP END MASTER
    2333 !$OMP BARRIER
     2318    !$OMP END MASTER
     2319    !$OMP BARRIER
    23342320
    23352321    SELECT CASE (varname)
    23362322
    2337     CASE("u","ua")
    2338 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    2339         DO l=1,llm
    2340             field_glo(:,2:jjm,l)=field_glo(:,2:jjm,l)/cu(:,2:jjm)
    2341             field_glo(:,1,l)=0. ; field_glo(:,jjp1,l)=0.
    2342         ENDDO
    2343     CASE("v","va")
    2344 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    2345         DO l=1,llm
    2346            field_glo(:,:,l)=field_glo(:,:,l)/cv(:,:)
    2347         ENDDO
     2323    CASE("u", "ua")
     2324      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     2325      DO l = 1, llm
     2326        field_glo(:, 2:jjm, l) = field_glo(:, 2:jjm, l) / cu(:, 2:jjm)
     2327        field_glo(:, 1, l) = 0. ; field_glo(:, jjp1, l) = 0.
     2328      ENDDO
     2329    CASE("v", "va")
     2330      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     2331      DO l = 1, llm
     2332        field_glo(:, :, l) = field_glo(:, :, l) / cv(:, :)
     2333      ENDDO
    23482334    END SELECT
    23492335
    2350 !    if (varname=="ua") THEN
    2351 !    CALL dump2d(iip1,jjp1,field_glo,'ua gui1 1ere couche ')
    2352 !    CALL dump2d(iip1,jjp1,field_glo(:,:,llm),'ua gui1 llm ')
    2353 !    endif
    2354 
    2355 !$OMP MASTER
    2356 
    2357     ierr = nf90_put_var(nid,varid,field_glo,start,count)
     2336    !    if (varname=="ua") THEN
     2337    !    CALL dump2d(iip1,jjp1,field_glo,'ua gui1 1ere couche ')
     2338    !    CALL dump2d(iip1,jjp1,field_glo(:,:,llm),'ua gui1 llm ')
     2339    !    endif
     2340
     2341    !$OMP MASTER
     2342
     2343    ierr = nf90_put_var(nid, varid, field_glo, start, count)
    23582344    ierr = nf90_close(nid)
    23592345
    2360        DEALLOCATE(field_glo)
    2361 !$OMP END MASTER
    2362 !$OMP BARRIER
     2346    DEALLOCATE(field_glo)
     2347    !$OMP END MASTER
     2348    !$OMP BARRIER
    23632349
    23642350  END SUBROUTINE guide_out
    2365    
    2366  
    2367 !===========================================================================
    2368   SUBROUTINE correctbid(iim,nl,x)
    2369     integer iim,nl
    2370     real x(iim+1,nl)
    2371     integer i,l
    2372     real zz
    2373 
    2374     do l=1,nl
    2375         do i=2,iim-1
    2376             IF(abs(x(i,l))>1.e10) THEN
    2377                zz=0.5*(x(i-1,l)+x(i+1,l))
    2378               PRINT*,'correction ',i,l,x(i,l),zz
    2379                x(i,l)=zz
    2380             endif
    2381          enddo
    2382      enddo
     2351
     2352
     2353  !===========================================================================
     2354  SUBROUTINE correctbid(iim, nl, x)
     2355    INTEGER iim, nl
     2356    REAL x(iim + 1, nl)
     2357    INTEGER i, l
     2358    REAL zz
     2359
     2360    do l = 1, nl
     2361      do i = 2, iim - 1
     2362        IF(abs(x(i, l))>1.e10) THEN
     2363          zz = 0.5 * (x(i - 1, l) + x(i + 1, l))
     2364          PRINT*, 'correction ', i, l, x(i, l), zz
     2365          x(i, l) = zz
     2366        endif
     2367      enddo
     2368    enddo
    23832369
    23842370  END SUBROUTINE  correctbid
    23852371
    23862372
    2387 !====================================================================
    2388 ! Ascii debug output. Could be reactivated
    2389 !====================================================================
    2390 
    2391 SUBROUTINE dump2du(var,varname)
    2392 use parallel_lmdz
    2393 use mod_hallo
    2394 IMPLICIT NONE
    2395 include 'dimensions.h'
    2396 include 'paramet.h'
    2397 
    2398       CHARACTER (len=*) :: varname
    2399 
    2400 
    2401 real, dimension(ijb_u:ije_u) :: var
    2402 
    2403 real, dimension(ip1jmp1) :: var_glob
     2373  !====================================================================
     2374  ! Ascii debug output. Could be reactivated
     2375  !====================================================================
     2376
     2377  SUBROUTINE dump2du(var, varname)
     2378    USE parallel_lmdz
     2379    USE mod_hallo
     2380    IMPLICIT NONE
     2381    include 'dimensions.h'
     2382    include 'paramet.h'
     2383
     2384    CHARACTER (len = *) :: varname
     2385
     2386    REAL, DIMENSION(ijb_u:ije_u) :: var
     2387
     2388    REAL, DIMENSION(ip1jmp1) :: var_glob
    24042389
    24052390    RETURN
    24062391
    24072392    CALL barrier
    2408     CALL Gather_field_u(var,var_glob,1)
     2393    CALL Gather_field_u(var, var_glob, 1)
    24092394    CALL barrier
    24102395
    2411     if (mpi_rank==0) THEN
    2412        CALL dump2d(iip1,jjp1,var_glob,varname)
     2396    IF (mpi_rank==0) THEN
     2397      CALL dump2d(iip1, jjp1, var_glob, varname)
    24132398    endif
    24142399
    24152400    CALL barrier
    24162401
    2417 
    2418     END SUBROUTINE  dump2du
    2419 
    2420 !====================================================================
    2421 ! Ascii debug output. Could be reactivated
    2422 !====================================================================
    2423 SUBROUTINE dumpall
    2424      IMPLICIT NONE
    2425      include "dimensions.h"
    2426      include "paramet.h"
    2427      include "comgeom.h"
    2428      CALL barrier
    2429      CALL dump2du(alpha_u(ijb_u:ije_u),'  alpha_u couche 1')
    2430      CALL dump2du(unat2(:,jjbu:jjeu,nlevnc),'  unat2 couche nlevnc')
    2431      CALL dump2du(ugui1(ijb_u:ije_u,1)*sqrt(unscu2(ijb_u:ije_u)),'  ugui1 couche 1')
    2432 
    2433 END SUBROUTINE  dumpall
    2434 
    2435 !===========================================================================
     2402  END SUBROUTINE  dump2du
     2403
     2404  !====================================================================
     2405  ! Ascii debug output. Could be reactivated
     2406  !====================================================================
     2407  SUBROUTINE dumpall
     2408    IMPLICIT NONE
     2409    include "dimensions.h"
     2410    include "paramet.h"
     2411    include "comgeom.h"
     2412    CALL barrier
     2413    CALL dump2du(alpha_u(ijb_u:ije_u), '  alpha_u couche 1')
     2414    CALL dump2du(unat2(:, jjbu:jjeu, nlevnc), '  unat2 couche nlevnc')
     2415    CALL dump2du(ugui1(ijb_u:ije_u, 1) * sqrt(unscu2(ijb_u:ije_u)), '  ugui1 couche 1')
     2416
     2417  END SUBROUTINE  dumpall
     2418
     2419  !===========================================================================
    24362420END MODULE guide_loc_mod

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

    r5116 r5117  
    77  USE infotrac,    ONLY: nqtot, niso, iqIsoPha, tracers, getKey, isoName
    88  USE control_mod, ONLY: day_step,planet_type
    9   use exner_hyb_m, ONLY: exner_hyb
    10   use exner_milieu_m, ONLY: exner_milieu
     9  USE exner_hyb_m, ONLY: exner_hyb
     10  USE exner_milieu_m, ONLY: exner_milieu
    1111  USE parallel_lmdz, ONLY: ijb_u, ije_u, ijb_v, ije_v
    1212  USE IOIPSL, ONLY: getin
    13   USE Write_Field
     13  USE lmdz_write_field
    1414  USE comconst_mod, ONLY: cpp, kappa, g, daysec, dtvr, pi, im, jm
    1515  USE logic_mod, ONLY: iflag_phys, read_start
    … …  
    1717  USE temps_mod, ONLY: annee_ref, day_ini, day_ref
    1818  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
    19   USE readTracFiles_mod, ONLY: addPhase
    20   use netcdf, ONLY: nf90_nowrite,nf90_open,nf90_noerr,nf90_inq_varid,nf90_close, nf90_get_var
     19  USE lmdz_readTracFiles, ONLY: addPhase
     20  USE netcdf, ONLY: nf90_nowrite,nf90_open,nf90_noerr,nf90_inq_varid,nf90_close, nf90_get_var
     21  USE lmdz_ran1, ONLY: ran1
    2122
    2223  !   Author:    Frederic Hourdin      original: 15/01/93
    … …  
    6061  REAL phi(ip1jmp1,llm)                  ! geopotentiel
    6162  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
    62   real tetastrat ! potential temperature in the stratosphere, in K
    63   real tetajl(jjp1,llm)
     63  REAL tetastrat ! potential temperature in the stratosphere, in K
     64  REAL tetajl(jjp1,llm)
    6465  INTEGER i,j,l,lsup,ij, iq, iName, iPhase, iqParent
    6566
    6667  INTEGER :: nid_relief,varid,ierr
    67   real, dimension(iip1,jjp1) :: relief
    68 
     68  REAL, DIMENSION(iip1,jjp1) :: relief
    6969
    7070  REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T
    … …  
    7474  REAL phi_pv,dphi_pv,gam_pv,tetanoise   ! Constantes pour polar vortex
    7575
    76   real zz,ran1
    77   integer idum
     76  REAL zz
     77  INTEGER idum
    7878
    7979  REAL zdtvr, tnat, alpha_ideal
    … …  
    8484
    8585  ! Sanity check: verify that options selected by user are not incompatible
    86   if ((iflag_phys==1).and. .not. read_start) THEN
     86  IF ((iflag_phys==1).AND. .NOT. read_start) THEN
    8787    WRITE(lunout,*) trim(modname)," error: if read_start is set to ", &
    8888    " false then iflag_phys should not be 1"
    … …  
    9090    " (iflag_phys >= 100)"
    9191    CALL abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.FALSE.",1)
    92   endif
     92  ENDIF
    9393 
    9494  !-----------------------------------------------------------------------
    … …  
    114114  ang0       = 0.
    115115
    116   if (llm == 1) THEN
     116  IF (llm == 1) THEN
    117117     ! specific initializations for the shallow water case
    118118     kappa=1
    119   endif
     119  ENDIF
    120120
    121121  CALL iniconst
    … …  
    148148     relief=0.
    149149     ierr = nf90_open ('relief_in.nc', nf90_nowrite,nid_relief)
    150      if (ierr==nf90_noerr) THEN
     150     IF (ierr==nf90_noerr) THEN
    151151         ierr=nf90_inq_varid(nid_relief,'RELIEF',varid)
    152          if (ierr==nf90_noerr) THEN
     152         IF (ierr==nf90_noerr) THEN
    153153              ierr=nf90_get_var(nid_relief,varid,relief(1:iim,1:jjp1))
    154154              relief(iip1,:)=relief(1,:)
    … …  
    173173
    174174     CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
    175      if (pressure_exner) THEN
     175     IF (pressure_exner) THEN
    176176       CALL exner_hyb( ip1jmp1, ps_glo, p, pks, pk )
    177177     else
    … …  
    181181  ENDIF
    182182
    183   if (llm == 1) THEN
     183  IF (llm == 1) THEN
    184184     ! initialize fields for the shallow water case, if required
    185      if (.not.read_start) THEN
     185     IF (.NOT.read_start) THEN
    186186        phis(ijb_u:ije_u)=0.
    187187        q(ijb_u:ije_u,1:llm,1:nqtot)=0
    188188        CALL sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
    189189     endif
    190   endif
     190  ENDIF
    191191
    192192  academic_case: if (iflag_phys >= 2) THEN
    … …  
    258258           tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin &
    259259                -delt_z*(1.-ddsin*ddsin)*log(zsig)
    260            if (planet_type=="giant") THEN
     260           IF (planet_type=="giant") THEN
    261261             tetajl(j,l)=teta0+(delt_y*                   &
    262262                ((sin(rlatu(j)*3.14159*eps+0.0001))**2)   &
    … …  
    295295
    296296        ! winds
    297         if (ok_geost) THEN
     297        IF (ok_geost) THEN
    298298           CALL ugeostr(phi,ucov_glo)
    299299        else
    … …  
    303303
    304304        ! bulk initialization of tracers
    305         if (planet_type=="earth") THEN
     305        IF (planet_type=="earth") THEN
    306306           ! Earth: first two tracers will be water
    307307           do iq=1,nqtot
    … …  
    313313              ! distill de Rayleigh très simplifiée
    314314              iName    = tracers(iq)%iso_iName
    315               if (niso <= 0 .OR. iName <= 0) CYCLE
     315              IF (niso <= 0 .OR. iName <= 0) CYCLE
    316316              iPhase   = tracers(iq)%iso_iPhase
    317317              iqParent = tracers(iq)%iqParent
    318318              IF(tracers(iq)%iso_iZone == 0) THEN
    319                  if (tnat1) THEN
     319                 IF (tnat1) THEN
    320320                         tnat=1.0
    321321                         alpha_ideal=1.0
    … …  
    374374        deallocate(phis_glo)
    375375     ENDIF ! of IF (.NOT. read_start)
    376   endif academic_case
     376  ENDIF academic_case
    377377
    378378END SUBROUTINE iniacademic_loc

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initdynav_loc.f90

    r5116 r5117  
    77   USE IOIPSL
    88   USE parallel_lmdz
    9    use Write_field
    10    use misc_mod
     9   USE lmdz_write_field
     10   USE misc_mod
    1111    ! USE infotrac
    12    use com_io_dyn_mod, ONLY: histaveid,histvaveid,histuaveid,       &
     12   USE com_io_dyn_mod, ONLY: histaveid,histvaveid,histuaveid,       &
    1313         dynhistave_file,dynhistvave_file,dynhistuave_file
    1414   USE comconst_mod, ONLY: pi
    … …  
    5151  !   Arguments
    5252  !
    53   integer(kind=4) day0, anne0
     53  INTEGER(kind=4) day0, anne0
    5454  REAL :: tstep, t_ops, t_wrt
    5555
    … …  
    8181  INTEGER :: dynhistuave_domain_id
    8282
    83   if (adjust) return
     83  IF (adjust) return
    8484
    8585  !
    … …  
    219219  !  Vents V
    220220  !
    221   if (pole_sud) jjn=jj_nb-1
     221  IF (pole_sud) jjn=jj_nb-1
    222222  CALL histdef(histvaveid, 'v', 'vent v moyen', &
    223223        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/initfluxsto_p.f90

    r5116 r5117  
    44  USE IOIPSL
    55  USE parallel_lmdz
    6   use Write_field
    7   use misc_mod
     6  USE lmdz_write_field
     7  USE misc_mod
    88  USE comconst_mod, ONLY: pi
    99  USE comvert_mod, ONLY: nivsigs
    … …  
    6464  INTEGER :: ii, jj
    6565  INTEGER :: zan, idayref
    66   logical :: ok_sync
     66  LOGICAL :: ok_sync
    6767  INTEGER :: jjb, jje, jjn
    6868
    … …  
    136136  jje = jj_end
    137137  jjn = jj_nb
    138   if (pole_sud) jje = jj_end - 1
    139   if (pole_sud) jjn = jj_nb - 1
     138  IF (pole_sud) jje = jj_end - 1
     139  IF (pole_sud) jjn = jj_nb - 1
    140140
    141141  ddid = (/ 1, 2 /)
    … …  
    156156  rl(1, 1) = 1.
    157157
    158   if (mpi_rank==0) THEN
     158  IF (mpi_rank==0) THEN
    159159    CALL histbeg('defstoke.nc', 1, rl, 1, rl, &
    160160            1, 1, 1, 1, &
    161161            tau0, zjulian, tstep, dhoriid, filedid)
    162162
    163   endif
     163  ENDIF
    164164  !
    165165  !  Appel a histhori pour rajouter les autres grilles horizontales
    … …  
    190190          llm, nivsigs, zvertiid)
    191191  ! pour le fichier def
    192   if (mpi_rank==0) THEN
     192  IF (mpi_rank==0) THEN
    193193    nivd(1) = 1
    194194    CALL histvert(filedid, 'sig_s', 'Niveaux sigma', &
    195195            'sigma_level', &
    196196            1, nivd, dvertiid)
    197   endif
     197  ENDIF
    198198  !
    199199  !  Appels a histdef pour la definition des variables a sauvegarder
    … …  
    207207          "once", t_ops, t_wrt)
    208208
    209   if (mpi_rank==0) THEN
     209  IF (mpi_rank==0) THEN
    210210    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
    211211            1, 1, dhoriid, 1, 1, 1, -99, 32, &
    … …  
    220220            "once", t_ops, t_wrt)
    221221
    222   endif
     222  ENDIF
    223223  !
    224224  ! Masse
    … …  
    237237  !  Pbarv
    238238  !
    239   if (pole_sud) jjn = jj_nb - 1
     239  IF (pole_sud) jjn = jj_nb - 1
    240240
    241241  CALL histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
    … …  
    245245  !  w
    246246  !
    247   if (pole_sud) jjn = jj_nb
     247  IF (pole_sud) jjn = jj_nb
    248248  CALL histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
    249249          iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
    … …  
    269269  CALL histend(fileid)
    270270  CALL histend(filevid)
    271   if (mpi_rank==0) CALL histend(filedid)
    272   if (ok_sync) THEN
     271  IF (mpi_rank==0) CALL histend(filedid)
     272  IF (ok_sync) THEN
    273273    CALL histsync(fileid)
    274274    CALL histsync(filevid)
    275     if (mpi_rank==0) CALL histsync(filedid)
    276   endif
     275    IF (mpi_rank==0) CALL histsync(filedid)
     276  ENDIF
    277277
    278278END SUBROUTINE initfluxsto_p

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

    r5116 r5117  
    66  USE IOIPSL
    77  USE parallel_lmdz
    8   USE Write_field
     8  USE lmdz_write_field
    99  USE misc_mod
    1010  USE com_io_dyn_mod, ONLY: histid, histvid, histuid, &
    … …  
    7878  INTEGER :: dynhistu_domain_id
    7979
    80   if (adjust) return
     80  IF (adjust) return
    8181
    8282  !
    … …  
    215215  !  Vents V
    216216  !
    217   if (pole_sud) jjn = jj_nb - 1
     217  IF (pole_sud) jjn = jj_nb - 1
    218218  CALL histdef(histvid, 'v', 'vent v', &
    219219          'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/integrd_loc.f90

    r5116 r5117  
    99  USE lmdz_filtreg_p
    1010  USE write_field_loc
    11   USE write_field
     11  USE lmdz_write_field
    1212  USE integrd_mod
    1313  USE comconst_mod, ONLY: pi
    … …  
    1515  USE comvert_mod, ONLY: ap, bp
    1616  USE temps_mod, ONLY: dt
    17   USE strings_mod, ONLY: int2str
     17  USE lmdz_strings, ONLY: int2str
    1818
    1919  IMPLICIT NONE
    … …  
    4343  !   ----------
    4444
    45   INTEGER,intent(in) :: nq ! number of tracers to handle in this routine
     45  INTEGER,INTENT(IN) :: nq ! number of tracers to handle in this routine
    4646
    4747  REAL,INTENT(INOUT) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
    … …  
    9090
    9191!$OMP BARRIER
    92   if (pole_nord) THEN
     92  IF (pole_nord) THEN
    9393!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    9494    DO  l = 1,llm
    … …  
    101101  ENDIF
    102102
    103   if (pole_sud) THEN
     103  IF (pole_sud) THEN
    104104!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    105105    DO  l = 1,llm
    … …  
    195195  !   !WRITE(*,*) 'integrd 200'
    196196!$OMP MASTER
    197   if (pole_nord) THEN
     197  IF (pole_nord) THEN
    198198
    199199    DO  ij    = 1, iim
    … …  
    207207  ENDIF
    208208
    209   if (pole_sud) THEN
     209  IF (pole_sud) THEN
    210210
    211211    DO  ij    = 1, iim
    … …  
    255255  ijb=ij_begin
    256256  ije=ij_end
    257   if (pole_nord) ijb=ij_begin+iip1
    258   if (pole_sud)  ije=ij_end-iip1
     257  IF (pole_nord) ijb=ij_begin+iip1
     258  IF (pole_sud)  ije=ij_end-iip1
    259259
    260260  DO ij = ijb,ije
    … …  
    265265  ijb=ij_begin
    266266  ije=ij_end
    267   if (pole_sud)  ije=ij_end-iip1
     267  IF (pole_sud)  ije=ij_end-iip1
    268268
    269269  DO ij = ijb,ije
    … …  
    320320    ucovm1(ijb:ije,l)=uscr(ijb:ije)
    321321    tetam1(ijb:ije,l)=hscr(ijb:ije)
    322     if (pole_sud) ije=ij_end-iip1
     322    IF (pole_sud) ije=ij_end-iip1
    323323    vcovm1(ijb:ije,l)=vscr(ijb:ije)
    324324
    … …  
    334334  ije=ij_end
    335335
    336      if (planet_type=="earth") THEN
     336     IF (planet_type=="earth") THEN
    337337  ! Earth-specific treatment of first 2 tracers (water)
    338338!$OMP BARRIER
    … …  
    415415  !c$OMP END DO NOWAIT
    416416
    417   endif ! of if (planet_type.eq."earth")
     417  ENDIF ! of if (planet_type.EQ."earth")
    418418
    419419  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_gam_loc.f90

    r5106 r5117  
    4545  ijb=ij_begin-iip1
    4646  ije=ij_end+iip1
    47   if (pole_nord) ijb=ij_begin
    48   if (pole_sud ) ije=ij_end
     47  IF (pole_nord) ijb=ij_begin
     48  IF (pole_sud ) ije=ij_end
    4949
    5050!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_loc.f90

    r5106 r5117  
    3636  ijb=ij_begin-iip1
    3737  ije=ij_end+iip1
    38   if (pole_nord) ijb=ij_begin
    39   if (pole_sud ) ije=ij_end
     38  IF (pole_nord) ijb=ij_begin
     39  IF (pole_sud ) ije=ij_end
    4040
    4141!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    4747  jjb=jj_begin-1
    4848  jje=jj_end+1
    49   if (pole_nord) jjb=jj_begin
    50   if (pole_sud ) jje=jj_end
     49  IF (pole_nord) jjb=jj_begin
     50  IF (pole_sud ) jje=jj_end
    5151
    5252  CALL filtreg_p( divgra,jjb_u,jje_u,jjb,jje,jjp1, &

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rot_loc.f90

    r5106 r5117  
    3535  jje=jj_end+1
    3636
    37   if (pole_nord) jjb=jj_begin
    38   if (pole_sud) jje=jj_end-1
     37  IF (pole_nord) jjb=jj_begin
     38  IF (pole_sud) jje=jj_end-1
    3939
    4040  CALL  filtreg_p ( rotin ,jjb_v,jje_v,jjb,jje,jjm, &

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

    r5116 r5117  
    99  USE mod_hallo
    1010  USE Bands
    11   USE strings_mod, ONLY: int2str
     11  USE lmdz_strings, ONLY: int2str
    1212  USE Write_Field_p
    13   USE vampir
     13  USE lmdz_vampir
    1414  USE lmdz_timer_filtre, ONLY: print_filtre_timer
    1515  USE infotrac
    … …  
    2727          , leapfrog_allocate, leapfrog_switch_caldyn, leapfrog_switch_dissip
    2828
    29   use exner_hyb_loc_m, ONLY: exner_hyb_loc
    30   use exner_milieu_loc_m, ONLY: exner_milieu_loc
     29  USE exner_hyb_loc_m, ONLY: exner_hyb_loc
     30  USE exner_milieu_loc_m, ONLY: exner_milieu_loc
    3131  USE comconst_mod, ONLY: cpp, dtvr, ihf
    3232  USE comvert_mod, ONLY: ap, bp, pressure_exner
    … …  
    150150  REAL :: secondes
    151151
    152   logical :: physic
     152  LOGICAL :: physic
    153153  LOGICAL :: first, callinigrads
    154154
    … …  
    213213  lafin = .FALSE.
    214214
    215   if (nday>=0) THEN
     215  IF (nday>=0) THEN
    216216    itaufin = nday * day_step
    217217  else
    218218    itaufin = -nday
    219   endif
     219  ENDIF
    220220
    221221  itaufinp1 = itaufin + 1
    … …  
    225225  itau = 0
    226226  physic = .TRUE.
    227   if (iflag_phys==0.or.iflag_phys==2) physic = .FALSE.
     227  IF (iflag_phys==0.OR.iflag_phys==2) physic = .FALSE.
    228228  CALL init_nan
    229229  CALL leapfrog_allocate
    … …  
    247247  ! Allocate variables depending on dynamic variable nqtot
    248248  !$OMP MASTER
    249   if (firstcall) THEN
     249  IF (firstcall) THEN
    250250    ! ALLOCATE(p(ijb_u:ije_u,llmp1))
    251251    !      ALLOCATE(pks(ijb_u:ije_u))
    … …  
    274274    ! ALLOCATE(vcont(ijb_v:ije_v,llm),ucont(ijb_u:ije_u,llm))
    275275    ! ALLOCATE(vnat(ijb_v:ije_v,llm),unat(ijb_u:ije_u,llm))
    276   endif
     276  ENDIF
    277277  !$OMP END MASTER
    278278  !$OMP BARRIER
    … …  
    290290  CALL pression (ijnb_u, ap, bp, ps, p)
    291291  !$OMP END MASTER
    292   if (pressure_exner) THEN
     292  IF (pressure_exner) THEN
    293293    CALL exner_hyb_loc(ijnb_u, ps, p, pks, pk, pkf)
    294294  else
    295295    CALL exner_milieu_loc(ijnb_u, ps, p, pks, pk, pkf)
    296   endif
     296  ENDIF
    297297  !-----------------------------------------------------------------------
    298298  !   Debut de l'integration temporelle:
    … …  
    309309  jH_cur = jH_ref + start_time + &
    310310          mod(itau + 1, day_step) / float(day_step)
    311   if (jH_cur > 1.0) THEN
     311  IF (jH_cur > 1.0) THEN
    312312    jD_cur = jD_cur + 1.
    313313    jH_cur = jH_cur - 1.
    314   endif
     314  ENDIF
    315315
    316316  CALL check_isotopes(q, ijb_u, ije_u, 'leapfrog 321')
    317317
    318   if (ok_guide) THEN
     318  IF (ok_guide) THEN
    319319    CALL guide_main(itau,ucov,vcov,teta,q,masse,ps)
    320320!$OMP BARRIER
    321   endif
     321  ENDIF
    322322
    323323
    … …  
    334334  !ym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
    335335
    336   if (FirstCaldyn) THEN
     336  IF (FirstCaldyn) THEN
    337337    !$OMP MASTER
    338338    ucovm1 = ucov
    … …  
    365365      ! finvmaold(ijb:ije,l)=masse(ijb:ije,l)
    366366
    367       if (pole_sud) ije = ij_end - iip1
     367      IF (pole_sud) ije = ij_end - iip1
    368368      vcovm1(ijb:ije, l) = vcov  (ijb:ije, l)
    369369
    … …  
    376376    ! .                    llm, -2,2, .TRUE., 1 )
    377377
    378   endif ! of if (FirstCaldyn)
     378  ENDIF ! of if (FirstCaldyn)
    379379
    380380  forward = .TRUE.
    … …  
    398398  !$OMP MASTER
    399399  ItCount = ItCount + 1
    400   if (MOD(ItCount, 1)==1) THEN
     400  IF (MOD(ItCount, 1)==1) THEN
    401401    debug = .TRUE.
    402402  else
    403403    debug = .FALSE.
    404   endif
     404  ENDIF
    405405  !$OMP END MASTER
    406406  !-----------------------------------------------------------------------
    … …  
    414414    jH_cur = jH_ref + start_time + &
    415415            mod(itau + 1, day_step) / float(day_step)
    416     if (jH_cur > 1.0) THEN
     416    IF (jH_cur > 1.0) THEN
    417417      jD_cur = jD_cur + 1.
    418418      jH_cur = jH_cur - 1.
    … …  
    436436            apdiss = .TRUE.
    437437    IF(MOD(itau, iphysiq)==0.AND..NOT.forward &
    438             .and. physic) apphys = .TRUE.
     438            .AND. physic) apphys = .TRUE.
    439439  ELSE
    440440    ! Leapfrog/Matsuno time stepping
    … …  
    447447  ! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
    448448  ! supress dissipation step
    449   if (llm==1) THEN
     449  IF (llm==1) THEN
    450450    apdiss = .FALSE.
    451   endif
     451  ENDIF
    452452
    453453  !ym    ---> Pour le moment
    … …  
    456456  ! conser = .FALSE. ! ie: no output of control variables to stdout in //
    457457
    458   if (firstCaldyn) THEN
     458  IF (firstCaldyn) THEN
    459459    !$OMP MASTER
    460460    CALL Set_Distrib(distrib_caldyn)
    … …  
    466466    CALL Init_timer
    467467    !$OMP END MASTER
    468   endif
     468  ENDIF
    469469
    470470  !$OMP MASTER
    … …  
    478478
    479479  !ym  PAS D'AJUSTEMENT POUR LE MOMENT
    480   if (Adjust) THEN
     480  IF (Adjust) THEN
    481481    AdjustCount = AdjustCount + 1
    482     ! if (iapptrac==iapp_tracvl .and. (forward .OR.  leapf)
    483     ! &         .and. itau/iphysiq>2 .and. Adjustcount>30) THEN
    484     if (Adjustcount>1) THEN
     482    ! if (iapptrac==iapp_tracvl .AND. (forward .OR.  leapf)
     483    ! &         .AND. itau/iphysiq>2 .AND. Adjustcount>30) THEN
     484    IF (Adjustcount>1) THEN
    485485      AdjustCount = 0
    486486      !$OMP MASTER
    487487      CALL allgather_timer_average
    488488
    489       if (prt_level > 9) THEN
     489      IF (prt_level > 9) THEN
    490490        print *, '*********************************'
    491491        print *, '******    TIMER CALDYN     ******'
    … …  
    586586
    587587      !$OMP MASTER
    588       if (mpi_rank==0) CALL WriteBands
     588      IF (mpi_rank==0) CALL WriteBands
    589589      !$OMP END MASTER
    590590
    591591    endif
    592   endif
     592  ENDIF
    593593
    594594  CALL check_isotopes(q, ijb_u, ije_u, 'leapfrog 589')
    … …  
    625625  !$OMP BARRIER
    626626
    627   if (debug) THEN
     627  IF (debug) THEN
    628628    CALL WriteField_u('ucov', ucov)
    629629    CALL WriteField_v('vcov', vcov)
    … …  
    639639              q(:, :, iq))
    640640    enddo
    641   endif
     641  ENDIF
    642642
    643643  True_itau = True_itau + 1
    … …  
    670670
    671671  !$OMP MASTER
    672   if (mpi_rank==0.AND.conser) THEN
     672  IF (mpi_rank==0.AND.conser) THEN
    673673    WRITE(lunout, *) 'leapfrog_loc, Time step: ', itau, ' Day:', time
    674674  ENDIF
    … …  
    728728  !$OMP END MASTER
    729729  IF (CPPKEY_DEBUGIO) THEN
    730     if (true_itau>20) THEN
     730    IF (true_itau>20) THEN
    731731      CALL WriteField_u('ucovm1', ucovm1)
    732732      CALL WriteField_v('vcovm1', vcovm1)
    … …  
    802802    ! c-jld
    803803    !$OMP MASTER
    804     if (FirstPhysic) THEN
     804    IF (FirstPhysic) THEN
    805805      ok_start_timer = .TRUE.
    806806      FirstPhysic = .FALSE.
    … …  
    814814  IF(iflag_phys==2) THEN ! "Newtonian" case
    815815    !$OMP MASTER
    816     if (FirstPhysic) THEN
     816    IF (FirstPhysic) THEN
    817817      ok_start_timer = .TRUE.
    818818      FirstPhysic = .FALSE.
    … …  
    838838
    839839    !$OMP MASTER
    840     if (planet_type=="giant") THEN
     840    IF (planet_type=="giant") THEN
    841841      ! add an intrinsic heat flux at the base of the atmosphere
    842842      teta(ijb:ije, 1) = teta(ijb:ije, 1) &
    … …  
    864864  CALL pression_loc (ip1jmp1, ap, bp, ps, p)
    865865  !$OMP BARRIER
    866   if (pressure_exner) THEN
     866  IF (pressure_exner) THEN
    867867    CALL exner_hyb_loc(ijnb_u, ps, p, pks, pk, pkf)
    868868  else
    869869    CALL exner_milieu_loc(ijnb_u, ps, p, pks, pk, pkf)
    870   endif
     870  ENDIF
    871871  !$OMP BARRIER
    872872  CALL massdair_loc(p, masse)
    … …  
    897897    CALL allgather_timer_average
    898898    CALL barrier
    899     if (mpi_rank==0) THEN
     899    IF (mpi_rank==0) THEN
    900900      print *, '*********************************'
    901901      print *, '******    TIMER CALDYN     ******'
    … …  
    944944    !$OMP END MASTER
    945945
    946     if (ok_guide) THEN
     946    IF (ok_guide) THEN
    947947      ! set ok_guide to false to avoid extra output
    948948      ! in following forward step
    … …  
    960960      ENDIF
    961961#ifdef REPROBUS
    962      if (type_trac == 'repr') CALL finalize_reprobus
     962     IF (type_trac == 'repr') CALL finalize_reprobus
    963963#endif
    964964
    … …  
    988988
    989989    IF(itau == itaufinp1) THEN
    990       if (flag_verif) THEN
     990      IF (flag_verif) THEN
    991991        WRITE(79, *) 'ucov', ucov
    992992        WRITE(80, *) 'vcov', vcov
    … …  
    10131013        ENDIF
    10141014#ifdef REPROBUS
    1015           if (type_trac == 'repr') CALL finalize_reprobus
     1015          IF (type_trac == 'repr') CALL finalize_reprobus
    10161016#endif
    10171017
    … …  
    10641064    IF(MOD(itau, iecri)==0) THEN
    10651065      ! Ehouarn: output only during LF or Backward Matsuno
    1066       if (leapf.or.(.not.leapf.and.(.not.forward))) THEN
     1066      IF (leapf.OR.(.NOT.leapf.AND.(.NOT.forward))) THEN
    10671067        !$OMP BARRIER
    10681068        !$OMP MASTER
    … …  
    10711071        !$OMP BARRIER
    10721072
    1073          if (ok_dyn_ins) THEN
     1073         IF (ok_dyn_ins) THEN
    10741074             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
    10751075                   masse,ps,phis)
    … …  
    10851085        ENDIF
    10861086
    1087       endif                 ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
     1087      endif                 ! of if (leapf.OR.(.NOT.leapf.AND.(.NOT.forward)))
    10881088
    10891089    ENDIF ! of IF(MOD(itau,iecri).EQ.0)
    … …  
    10931093      !$OMP BARRIER
    10941094
    1095       ! if (planet_type.eq."earth") THEN
     1095      ! if (planet_type.EQ."earth") THEN
    10961096      ! Write an Earth-format restart file
    10971097      CALL dynredem1_loc("restart.nc", 0.0, &
    10981098              vcov, ucov, teta, q, masse, ps)
    1099       ! endif ! of if (planet_type.eq."earth")
    1100       if (ok_guide) THEN
     1099      ! END IF ! of if (planet_type.EQ."earth")
     1100      IF (ok_guide) THEN
    11011101        ! set ok_guide to false to avoid extra output
    11021102        ! in following forward step
    … …  
    11411141    !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
    11421142
    1143   ELSE ! of IF (.not.purmats)
     1143  ELSE ! of IF (.NOT.purmats)
    11441144
    11451145    CALL check_isotopes(q, ijb_u, ije_u, 'leapfrog 1664')
    … …  
    11751175          ENDIF
    11761176#ifdef REPROBUS
    1177              if (type_trac == 'repr') CALL finalize_reprobus
     1177             IF (type_trac == 'repr') CALL finalize_reprobus
    11781178#endif
    11791179
    … …  
    12261226
    12271227
    1228           if (ok_dyn_ins) THEN
     1228          IF (ok_dyn_ins) THEN
    12291229             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
    12301230                   masse,ps,phis)
    … …  
    12431243
    12441244      IF(itau==itaufin) THEN
    1245         ! if (planet_type.eq."earth") THEN
     1245        ! if (planet_type.EQ."earth") THEN
    12461246        CALL dynredem1_loc("restart.nc", 0.0, &
    12471247                vcov, ucov, teta, q, masse, ps)
    1248         ! endif ! of if (planet_type.eq."earth")
    1249         if (ok_guide) THEN
     1248        ! END IF ! of if (planet_type.EQ."earth")
     1249        IF (ok_guide) THEN
    12501250          ! set ok_guide to false to avoid extra output
    12511251          ! in following forward step
    … …  
    12621262    CALL check_isotopes(q, ijb_u, ije_u, 'leapfrog 1750')
    12631263
    1264   END IF ! of IF(.not.purmats)
     1264  END IF ! of IF(.NOT.purmats)
    12651265  !$OMP MASTER
    12661266  CALL fin_getparam
    … …  
    12771277    ENDIF
    12781278#ifdef REPROBUS
    1279   if (type_trac == 'repr') CALL finalize_reprobus
     1279  IF (type_trac == 'repr') CALL finalize_reprobus
    12801280#endif
    12811281

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

    r5116 r5117  
    7171          phis_dyn, q_dyn, flxw_dyn)
    7272    USE dimensions_mod
    73     use exner_hyb_loc_m, ONLY: exner_hyb_loc
    74     use exner_milieu_loc_m, ONLY: exner_milieu_loc
     73    USE exner_hyb_loc_m, ONLY: exner_hyb_loc
     74    USE exner_milieu_loc_m, ONLY: exner_milieu_loc
    7575    USE parallel_lmdz
    7676    USE times
    7777    USE mod_hallo
    7878    USE Bands
    79     USE vampir
     79    USE lmdz_vampir
    8080    USE infotrac, ONLY: nqtot
    8181    USE control_mod
    8282    USE write_field_loc
    83     USE strings_mod, ONLY: int2str
     83    USE lmdz_strings, ONLY: int2str
    8484    USE comconst_mod, ONLY: dtphys
    8585    USE logic_mod, ONLY: leapf, forward, ok_strato
    … …  
    144144    jH_cur = jH_ref + start_time + &
    145145            mod(itau + 1, day_step) / float(day_step)
    146     if (jH_cur > 1.0) THEN
     146    IF (jH_cur > 1.0) THEN
    147147      jD_cur = jD_cur + 1.
    148148      jH_cur = jH_cur - 1.
    … …  
    231231    ijb = ij_begin
    232232    ije = ij_end
    233     IF (.not. pole_nord) THEN
     233    IF (.NOT. pole_nord) THEN
    234234
    235235      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    246246      !$OMP END MASTER
    247247
    248     ENDIF ! of if ( .not. pole_nord)
     248    ENDIF ! of if ( .NOT. pole_nord)
    249249
    250250    !$OMP BARRIER
    … …  
    275275    !$OMP BARRIER
    276276    ijb = ij_begin
    277     IF (.not. pole_nord) THEN
     277    IF (.NOT. pole_nord) THEN
    278278
    279279      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    290290      !$OMP END MASTER
    291291
    292     endif ! of if (.not. pole_nord)
     292    endif ! of if (.NOT. pole_nord)
    293293
    294294    IF (CPPKEY_DEBUGIO) THEN
    … …  
    334334    CALL massdair_loc(p, masse)
    335335    !$OMP BARRIER
    336     if (pressure_exner) THEN
     336    IF (pressure_exner) THEN
    337337      CALL exner_hyb_loc(ijnb_u, ps, p, pks, pk, pkf)
    338338    else

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

    r5113 r5117  
    102102    !-------------------------------------------------------c
    103103
    104     IF(ifiltre==1.or.ifiltre==-1) &
     104    IF(ifiltre==1.OR.ifiltre==-1) &
    105105            CALL abort_gcm("lmdz_filtreg_p", 'Pas de transformee&
    106106                    &simple dans cette version', 1)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/massdair_loc.f90

    r5105 r5117  
    8888  ije=ij_end+2*iip1
    8989
    90   if (pole_nord) ijb=ij_begin
    91   if (pole_sud)  ije=ij_end
     90  IF (pole_nord) ijb=ij_begin
     91  IF (pole_sud)  ije=ij_end
    9292
    9393!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

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

    r5116 r5117  
    1818    USE mod_prism
    1919#endif
    20     USE wxios, ONLY: wxios_init, using_xios
     20    USE lmdz_wxios, ONLY: wxios_init, using_xios
    2121    IMPLICIT NONE
    2222
    … …  
    5656  SUBROUTINE Init_mpi
    5757    USE lmdz_mpi
    58     USE wxios, ONLY: wxios_init, using_xios
     58    USE lmdz_wxios, ONLY: wxios_init, using_xios
    5959
    6060  IMPLICIT NONE

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

    r5116 r5117  
    33IMPLICIT NONE
    44  logical,save :: use_mpi_alloc
    5   integer, parameter :: MaxProc=512
    6   integer, parameter :: DefaultMaxBufferSize=1024*1024*100
    7   integer, SAVE :: MaxBufferSize=0
    8   integer, parameter :: ListSize=1000
    9  
    10   integer,save       :: MaxBufferSize_Used
     5  INTEGER, parameter :: MaxProc=512
     6  INTEGER, parameter :: DefaultMaxBufferSize=1024*1024*100
     7  INTEGER, SAVE :: MaxBufferSize=0
     8  INTEGER, parameter :: ListSize=1000
     9 
     10  INTEGER,save       :: MaxBufferSize_Used
    1111!$OMP THREADPRIVATE( MaxBufferSize_Used)
    1212
    13    real,save,pointer,dimension(:) :: Buffer
     13   REAL,SAVE,pointer,DIMENSION(:) :: Buffer
    1414!$OMP THREADPRIVATE(Buffer)
    1515
    16    integer,save,dimension(Listsize) :: Buffer_Pos
    17    integer,save :: Index_Pos
     16   INTEGER,SAVE,DIMENSION(Listsize) :: Buffer_Pos
     17   INTEGER,save :: Index_Pos
    1818!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
    1919   
    2020  type Hallo
    21     real, dimension(:,:),pointer :: Field
     21    REAL, DIMENSION(:,:),pointer :: Field
    2222    INTEGER :: offset
    2323    INTEGER :: size
    … …  
    3737
    3838  type request
    39     type(request_SR),dimension(0:MaxProc-1) :: RequestSend
    40     type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
     39    type(request_SR),DIMENSION(0:MaxProc-1) :: RequestSend
     40    type(request_SR),DIMENSION(0:MaxProc-1) :: RequestRecv
    4141    INTEGER :: tag=1
    4242  end type request
    … …  
    143143    INTEGER :: Pos
    144144
    145     if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size 
    146     if (Buffer_pos(Index_pos)+Size>MaxBufferSize) THEN
     145    IF (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size
     146    IF (Buffer_pos(Index_pos)+Size>MaxBufferSize) THEN
    147147      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
    148148      CALL abort_gcm("mod_hallo","stopped",1)
    149149    endif
    150150   
    151     if (Index_pos>=ListSize) THEN
     151    IF (Index_pos>=ListSize) THEN
    152152      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
    153153      CALL abort_gcm("mod_hallo","stopped",1)
    … …  
    167167    Buffer_Pos(Index)=-1
    168168   
    169     do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
     169    do while (Buffer_Pos(Index_Pos)==-1 .AND. Index_Pos>1)
    170170      Index_Pos=Index_Pos-1
    171171    END DO
    … …  
    187187    INTEGER :: size
    188188    INTEGER :: offset
    189     real, dimension(Stride,NbLevel),target :: Field
     189    REAL, DIMENSION(Stride,NbLevel),target :: Field
    190190    type(request_SR),pointer :: Ptr_request
    191191    type(Hallo),POINTER :: NewHallos(:),HalloSwitch(:), NewHallo
    … …  
    220220   
    221221      INTEGER :: ij,ll,offset,size,target
    222       REAL, dimension(ij,ll) :: Field
     222      REAL, DIMENSION(ij,ll) :: Field
    223223      type(request),target :: a_request
    224224      type(request_SR),pointer :: Ptr_request
    … …  
    236236   
    237237      INTEGER :: ij,ll,offset,size,target
    238       REAL, dimension(ij,ll) :: Field
     238      REAL, DIMENSION(ij,ll) :: Field
    239239      type(request),target :: a_request
    240240      type(request_SR),pointer :: Ptr_request
    … …  
    253253   
    254254    INTEGER :: ij,ll
    255     REAL, dimension(ij,ll) :: FieldS
    256     REAL, dimension(ij,ll) :: FieldR
     255    REAL, DIMENSION(ij,ll) :: FieldS
     256    REAL, DIMENSION(ij,ll) :: FieldR
    257257    type(request) :: a_request
    258     integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
    259     integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
     258    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New
     259    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
    260260   
    261261    INTEGER ::i,jje,jjb
    … …  
    269269   
    270270    do i=0,MPI_Size-1
    271       if (i /= MPI_Rank) THEN
     271      IF (i /= MPI_Rank) THEN
    272272        jjb=max(jj_begin_new(i),jj_begin)
    273273        jje=min(jj_end_new(i),jj_end)
    274274       
    275         if (ij==ip1jm .and. jje==jjp1) jje=jjm
    276        
    277         if (jje >= jjb) THEN
     275        IF (ij==ip1jm .AND. jje==jjp1) jje=jjm
     276       
     277        IF (jje >= jjb) THEN
    278278          CALL Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
    279279        endif
    … …  
    282282        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
    283283       
    284         if (ij==ip1jm .and. jje==jjp1) jje=jjm
    285        
    286         if (jje >= jjb) THEN
     284        IF (ij==ip1jm .AND. jje==jjp1) jje=jjm
     285       
     286        IF (jje >= jjb) THEN
    287287          CALL Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
    288288        endif
    … …  
    301301   
    302302    INTEGER :: ij,ll,Up,Down
    303     REAL, dimension(ij,ll) :: FieldS
    304     REAL, dimension(ij,ll) :: FieldR
     303    REAL, DIMENSION(ij,ll) :: FieldS
     304    REAL, DIMENSION(ij,ll) :: FieldR
    305305    type(request) :: a_request
    306     integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
    307     integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
     306    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New
     307    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
    308308   
    309309    INTEGER ::i,jje,jjb
    … …  
    322322   
    323323    do i=0,MPI_Size-1
    324       if (i /= MPI_Rank) THEN
     324      IF (i /= MPI_Rank) THEN
    325325        jjb=max(jj_begin_new(i),jj_begin)
    326326        jje=min(jj_end_new(i),jj_end)
    327327       
    328         if (ij==ip1jm .and. jje==jjp1) jje=jjm
    329        
    330         if (jje >= jjb) THEN
     328        IF (ij==ip1jm .AND. jje==jjp1) jje=jjm
     329       
     330        IF (jje >= jjb) THEN
    331331          CALL Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
    332332        endif
    … …  
    335335        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
    336336       
    337         if (ij==ip1jm .and. jje==jjp1) jje=jjm
    338        
    339         if (jje >= jjb) THEN
     337        IF (ij==ip1jm .AND. jje==jjp1) jje=jjm
     338       
     339        IF (jje >= jjb) THEN
    340340          CALL Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
    341341        endif
    … …  
    11531153
    11541154      INTEGER :: ij,ll
    1155       REAL, dimension(ij,ll) :: Field
     1155      REAL, DIMENSION(ij,ll) :: Field
    11561156      INTEGER :: Sup,Sdown,rup,rdown
    11571157      type(request) :: a_request
    … …  
    11761176      ENDIF
    11771177     
    1178       if (Sup==0) THEN
     1178      IF (Sup==0) THEN
    11791179        SendUp=.FALSE.
    11801180       endif
    11811181     
    1182       if (Sdown==0) THEN
     1182      IF (Sdown==0) THEN
    11831183        SendDown=.FALSE.
    11841184      endif
    11851185
    1186       if (Rup==0) THEN
     1186      IF (Rup==0) THEN
    11871187        RecvUp=.FALSE.
    11881188      endif
    11891189     
    1190       if (Rdown==0) THEN
     1190      IF (Rdown==0) THEN
    11911191        RecvDown=.FALSE.
    11921192      endif
    … …  
    12171217      IMPLICIT NONE
    12181218      INTEGER :: ll
    1219       REAL, dimension(ijb_u:ije_u,ll) :: Field
     1219      REAL, DIMENSION(ijb_u:ije_u,ll) :: Field
    12201220      INTEGER :: Sup,Sdown,rup,rdown
    12211221      type(request) :: a_request
    … …  
    12401240      ENDIF
    12411241     
    1242       if (Sup==0) THEN
     1242      IF (Sup==0) THEN
    12431243        SendUp=.FALSE.
    12441244       endif
    12451245     
    1246       if (Sdown==0) THEN
     1246      IF (Sdown==0) THEN
    12471247        SendDown=.FALSE.
    12481248      endif
    12491249
    1250       if (Rup==0) THEN
     1250      IF (Rup==0) THEN
    12511251        RecvUp=.FALSE.
    12521252      endif
    12531253     
    1254       if (Rdown==0) THEN
     1254      IF (Rdown==0) THEN
    12551255        RecvDown=.FALSE.
    12561256      endif
    … …  
    12801280      IMPLICIT NONE
    12811281      INTEGER :: ll
    1282       REAL, dimension(ijb_v:ije_v,ll) :: Field
     1282      REAL, DIMENSION(ijb_v:ije_v,ll) :: Field
    12831283      INTEGER :: Sup,Sdown,rup,rdown
    12841284      type(request) :: a_request
    … …  
    13031303      ENDIF
    13041304     
    1305       if (Sup==0) THEN
     1305      IF (Sup==0) THEN
    13061306        SendUp=.FALSE.
    13071307       endif
    13081308     
    1309       if (Sdown==0) THEN
     1309      IF (Sdown==0) THEN
    13101310        SendDown=.FALSE.
    13111311      endif
    13121312
    1313       if (Rup==0) THEN
     1313      IF (Rup==0) THEN
    13141314        RecvUp=.FALSE.
    13151315      endif
    13161316     
    1317       if (Rdown==0) THEN
     1317      IF (Rdown==0) THEN
    13181318        RecvDown=.FALSE.
    13191319      endif
    … …  
    13491349      INTEGER :: i,rank,l,ij,Pos,ierr
    13501350      INTEGER :: offset
    1351       real,dimension(:,:),pointer :: Field
     1351      REAL,DIMENSION(:,:),pointer :: Field
    13521352      INTEGER :: Nb
    13531353       
    … …  
    13671367     
    13681368         Req%BufferSize=SizeBuffer
    1369          if (Req%NbRequest>0) THEN
     1369         IF (Req%NbRequest>0) THEN
    13701370          CALL allocate_buffer(SizeBuffer,Req%Index,Req%pos)
    13711371
    … …  
    13891389          enddo
    13901390   
    1391          if (SizeBuffer>0) THEN
     1391         IF (SizeBuffer>0) THEN
    13921392!$OMP CRITICAL (MPI)
    13931393         
    … …  
    14261426          Req%BufferSize=SizeBuffer
    14271427         
    1428           if (Req%NbRequest>0) THEN
     1428          IF (Req%NbRequest>0) THEN
    14291429          CALL allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
    14301430   
    1431           if (SizeBuffer>0) THEN
     1431          IF (SizeBuffer>0) THEN
    14321432!$OMP CRITICAL (MPI)
    14331433
    … …  
    14621462      type(request_SR),pointer :: Req
    14631463      type(Hallo),pointer :: PtrHallo
    1464       integer, dimension(2*mpi_size) :: TabRequest
    1465       integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
     1464      INTEGER, DIMENSION(2*mpi_size) :: TabRequest
     1465      INTEGER, DIMENSION(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
    14661466      INTEGER :: NbRequest
    14671467      INTEGER :: i,rank,pos,ij,l,ierr
    … …  
    14731473      do rank=0,MPI_SIZE-1
    14741474        Req=>a_request%RequestSend(rank)
    1475         if (Req%NbRequest>0 .AND. Req%BufferSize > 0) THEN
     1475        IF (Req%NbRequest>0 .AND. Req%BufferSize > 0) THEN
    14761476          NbRequest=NbRequest+1
    14771477          TabRequest(NbRequest)=Req%MSG_Request
    … …  
    14811481      do rank=0,MPI_SIZE-1
    14821482        Req=>a_request%RequestRecv(rank)
    1483         if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
     1483        IF (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
    14841484          NbRequest=NbRequest+1
    14851485          TabRequest(NbRequest)=Req%MSG_Request
    … …  
    14871487      enddo
    14881488     
    1489       if (NbRequest>0) THEN
     1489      IF (NbRequest>0) THEN
    14901490!$OMP CRITICAL (MPI)
    14911491!        PRINT *,"-------------------------------------------------------------------"
    … …  
    14991499      do rank=0,MPI_Size-1
    15001500        Req=>a_request%RequestRecv(rank)
    1501         if (Req%NbRequest>0) THEN
     1501        IF (Req%NbRequest>0) THEN
    15021502          Pos=Req%Pos
    15031503          do i=1,Req%NbRequest
    … …  
    15221522      do rank=0,MPI_SIZE-1
    15231523        Req=>a_request%RequestSend(rank)
    1524         if (Req%NbRequest>0) THEN
     1524        IF (Req%NbRequest>0) THEN
    15251525          CALL deallocate_buffer(Req%Index)
    15261526          Req%NbRequest=0
    … …  
    15301530      do rank=0,MPI_SIZE-1
    15311531        Req=>a_request%RequestRecv(rank)
    1532         if (Req%NbRequest>0) THEN
     1532        IF (Req%NbRequest>0) THEN
    15331533          CALL deallocate_buffer(Req%Index)
    15341534          Req%NbRequest=0
    … …  
    15471547      type(request_SR),pointer :: Req
    15481548      type(Hallo),pointer :: PtrHallo
    1549       integer, dimension(mpi_size) :: TabRequest
    1550       integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
     1549      INTEGER, DIMENSION(mpi_size) :: TabRequest
     1550      INTEGER, DIMENSION(MPI_STATUS_SIZE,mpi_size) :: TabStatus
    15511551      INTEGER :: NbRequest
    15521552      INTEGER :: i,rank,pos,ij,l,ierr
    … …  
    15571557      do rank=0,MPI_SIZE-1
    15581558        Req=>a_request%RequestSend(rank)
    1559         if (Req%NbRequest>0) THEN
     1559        IF (Req%NbRequest>0) THEN
    15601560          NbRequest=NbRequest+1
    15611561          TabRequest(NbRequest)=Req%MSG_Request
    … …  
    15641564     
    15651565
    1566       if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
     1566      IF (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
    15671567!$OMP CRITICAL (MPI)     
    15681568!        PRINT *,"-------------------------------------------------------------------"
    … …  
    15781578      do rank=0,MPI_SIZE-1
    15791579        Req=>a_request%RequestSend(rank)
    1580         if (Req%NbRequest>0) THEN
     1580        IF (Req%NbRequest>0) THEN
    15811581          CALL deallocate_buffer(Req%Index)
    15821582          Req%NbRequest=0
    … …  
    15941594      type(request_SR),pointer :: Req
    15951595      type(Hallo),pointer :: PtrHallo
    1596       integer, dimension(mpi_size) :: TabRequest
    1597       integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
     1596      INTEGER, DIMENSION(mpi_size) :: TabRequest
     1597      INTEGER, DIMENSION(MPI_STATUS_SIZE,mpi_size) :: TabStatus
    15981598      INTEGER :: NbRequest
    15991599      INTEGER :: i,rank,pos,ij,l,ierr
    … …  
    16051605      do rank=0,MPI_SIZE-1
    16061606        Req=>a_request%RequestRecv(rank)
    1607         if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
     1607        IF (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
    16081608          NbRequest=NbRequest+1
    16091609          TabRequest(NbRequest)=Req%MSG_Request
    … …  
    16121612     
    16131613     
    1614       if (NbRequest>0) THEN
     1614      IF (NbRequest>0) THEN
    16151615!$OMP CRITICAL (MPI)     
    16161616!        PRINT *,"-------------------------------------------------------------------"
    … …  
    16251625      do rank=0,MPI_Size-1
    16261626        Req=>a_request%RequestRecv(rank)
    1627         if (Req%NbRequest>0) THEN
     1627        IF (Req%NbRequest>0) THEN
    16281628          Pos=Req%Pos
    16291629          do i=1,Req%NbRequest
    … …  
    16471647      do rank=0,MPI_SIZE-1
    16481648        Req=>a_request%RequestRecv(rank)
    1649         if (Req%NbRequest>0) THEN
     1649        IF (Req%NbRequest>0) THEN
    16501650          CALL deallocate_buffer(Req%Index)
    16511651          Req%NbRequest=0
    … …  
    16641664   
    16651665    INTEGER :: ij,ll,l
    1666     REAL, dimension(ij,ll) :: FieldS
    1667     REAL, dimension(ij,ll) :: FieldR
    1668     integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
    1669     integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
     1666    REAL, DIMENSION(ij,ll) :: FieldS
     1667    REAL, DIMENSION(ij,ll) :: FieldR
     1668    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New
     1669    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
    16701670   
    16711671    INTEGER ::i,jje,jjb,ijb,ije
    … …  
    16801680    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
    16811681    jje=min(jj_end,jj_end_new(MPI_Rank))
    1682     if (ij==ip1jm) jje=min(jje,jjm)
    1683 
    1684     if (jje >= jjb) THEN
     1682    IF (ij==ip1jm) jje=min(jje,jjm)
     1683
     1684    IF (jje >= jjb) THEN
    16851685      ijb=(jjb-1)*iip1+1
    16861686      ije=jje*iip1
    … …  
    17021702   
    17031703    INTEGER :: ij,ll,Up,Down
    1704     REAL, dimension(ij,ll) :: FieldS
    1705     REAL, dimension(ij,ll) :: FieldR
    1706     integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
    1707     integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
     1704    REAL, DIMENSION(ij,ll) :: FieldS
     1705    REAL, DIMENSION(ij,ll) :: FieldR
     1706    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New
     1707    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
    17081708
    17091709    INTEGER ::i,jje,jjb,ijb,ije,l
    … …  
    17201720    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
    17211721    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
    1722     if (ij==ip1jm) jje=min(jje,jjm)
    1723    
    1724    
    1725     if (jje >= jjb) THEN
     1722    IF (ij==ip1jm) jje=min(jje,jjm)
     1723   
     1724   
     1725    IF (jje >= jjb) THEN
    17261726      ijb=(jjb-1)*iip1+1
    17271727      ije=jje*iip1
    … …  
    17431743     REAL :: field_glo(ip1jmp1,ll)
    17441744     type(request) :: request_gather
    1745      integer       :: l
     1745     INTEGER       :: l
    17461746
    17471747
    … …  
    17671767     type(request) :: request_gather
    17681768     INTEGER :: ijb,ije
    1769      integer       :: l
     1769     INTEGER       :: l
    17701770     
    17711771   
    17721772     ijb=ij_begin
    17731773     ije=ij_end
    1774      if (pole_sud) ije=ij_end-iip1
     1774     IF (pole_sud) ije=ij_end-iip1
    17751775       
    17761776!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    17951795     type(request) :: request_gather
    17961796     TYPE(distrib) :: distrib_swap
    1797      integer       :: l
     1797     INTEGER       :: l
    17981798     
    17991799!$OMP BARRIER
    … …  
    18291829     type(request) :: request_gather
    18301830     TYPE(distrib) :: distrib_swap
    1831      integer       :: ijb,ije,l
     1831     INTEGER       :: ijb,ije,l
    18321832     
    18331833
    … …  
    18491849     ijb=ij_begin
    18501850     ije=ij_end
    1851      if (pole_sud) ije=ij_end-iip1
     1851     IF (pole_sud) ije=ij_end-iip1
    18521852     
    18531853!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

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

    r5103 r5117  
    1515
    1616     USE lmdz_xios
    17      USE wxios, ONLY: g_comm
     17     USE lmdz_wxios, ONLY: g_comm
    1818     CHARACTER(len=100), SAVE :: dyn3d_ctx_name = "LMDZDYN"
    1919     TYPE(xios_context), SAVE :: dyn3d_ctx_handle

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_gam_loc.f90

    r5116 r5117  
    5252  END DO
    5353
    54   if (pole_nord) THEN
     54  IF (pole_nord) THEN
    5555    DO  ij = 1,iip1
    5656     x(    ij    ,l ) = 0.
    5757    ENDDO
    58   endif
     58  ENDIF
    5959
    60   if (pole_sud) THEN
     60  IF (pole_sud) THEN
    6161    DO  ij = 1,iip1
    6262     x( ij +ip1jm,l ) = 0.
    6363    ENDDO
    64   endif
     64  ENDIF
    6565  !
    6666  END DO

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_loc.f90

    r5116 r5117  
    2727  ijb=ij_begin
    2828  ije=ij_end
    29   if (pole_sud)  ije=ij_end-iip1
     29  IF (pole_sud)  ije=ij_end-iip1
    3030
    3131  DO ij = ijb+1, ije
    … …  
    4444  ije=ij_end+iip1
    4545
    46   if (pole_nord)  ijb=ij_begin+iip1
    47   if (pole_sud)  ije=ij_end-iip1
     46  IF (pole_nord)  ijb=ij_begin+iip1
     47  IF (pole_sud)  ije=ij_end-iip1
    4848
    4949  DO ij = ijb,ije
    … …  
    5151  END DO
    5252
    53   if (pole_nord) THEN
     53  IF (pole_nord) THEN
    5454    DO ij = 1,iip1
    5555      x(    ij    ,l ) = 0.
    5656    ENDDO
    57   endif
     57  ENDIF
    5858
    59   if (pole_sud) THEN
     59  IF (pole_sud) THEN
    6060    DO ij = 1,iip1
    6161      x( ij +ip1jm,l ) = 0.
    6262    ENDDO
    63   endif
     63  ENDIF
    6464  !
    6565  END DO

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgraro2_loc.f90

    r5116 r5117  
    107107  jjb=jj_begin
    108108  jje=jj_end
    109   if (pole_sud) jje=jj_end-1
     109  IF (pole_sud) jje=jj_end-1
    110110
    111111  CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm, &

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

    r5116 r5117  
    55  USE mod_const_mpi
    66  USE lmdz_mpi, ONLY: using_mpi
    7       use IOIPSL
     7      USE IOIPSL
    88    INTEGER,PARAMETER :: halo_max=3
    99   
    … …  
    1212!$OMP THREADPRIVATE(is_master)
    1313   
    14     integer, save :: mpi_size
    15     integer, save :: mpi_rank
    16     integer, save :: jj_begin
    17     integer, save :: jj_end
    18     integer, save :: jj_nb
    19     integer, save :: ij_begin
    20     integer, save :: ij_end
     14    INTEGER, save :: mpi_size
     15    INTEGER, save :: mpi_rank
     16    INTEGER, save :: jj_begin
     17    INTEGER, save :: jj_end
     18    INTEGER, save :: jj_nb
     19    INTEGER, save :: ij_begin
     20    INTEGER, save :: ij_end
    2121    logical, save :: pole_nord
    2222    logical, save :: pole_sud
    2323
    24     integer,save  :: jjb_u
    25     integer,save  :: jje_u
    26     integer,save  :: jjnb_u
    27     integer,save  :: jjb_v
    28     integer,save  :: jje_v
    29     integer,save  :: jjnb_v   
    30 
    31     integer,save  :: ijb_u
    32     integer,save  :: ije_u
    33     integer,save  :: ijnb_u   
    34    
    35     integer,save  :: ijb_v
    36     integer,save  :: ije_v
    37     integer,save  :: ijnb_v   
     24    INTEGER,save  :: jjb_u
     25    INTEGER,save  :: jje_u
     26    INTEGER,save  :: jjnb_u
     27    INTEGER,save  :: jjb_v
     28    INTEGER,save  :: jje_v
     29    INTEGER,save  :: jjnb_v
     30
     31    INTEGER,save  :: ijb_u
     32    INTEGER,save  :: ije_u
     33    INTEGER,save  :: ijnb_u
     34   
     35    INTEGER,save  :: ijb_v
     36    INTEGER,save  :: ije_v
     37    INTEGER,save  :: ijnb_v
    3838     
    3939   
    40     integer, allocatable, save, dimension(:) :: jj_begin_para
    41     integer, allocatable, save, dimension(:) :: jj_end_para
    42     integer, allocatable, save, dimension(:) :: jj_nb_para
    43     integer, save :: OMP_CHUNK
    44     integer, save :: omp_rank
    45     integer, save :: omp_size 
     40    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: jj_begin_para
     41    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: jj_end_para
     42    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: jj_nb_para
     43    INTEGER, save :: OMP_CHUNK
     44    INTEGER, save :: omp_rank
     45    INTEGER, save :: omp_size
    4646!$OMP THREADPRIVATE(omp_rank)
    4747
    … …  
    5353      INTEGER :: ij_end
    5454
    55       integer  :: jjb_u
    56       integer  :: jje_u
    57       integer  :: jjnb_u
    58       integer  :: jjb_v
    59       integer  :: jje_v
    60       integer  :: jjnb_v   
     55      INTEGER  :: jjb_u
     56      INTEGER  :: jje_u
     57      INTEGER  :: jjnb_u
     58      INTEGER  :: jjb_v
     59      INTEGER  :: jje_v
     60      INTEGER  :: jjnb_v
    6161 
    62       integer  :: ijb_u
    63       integer  :: ije_u
    64       integer  :: ijnb_u   
    65    
    66       integer  :: ijb_v
    67       integer  :: ije_v
    68       integer  :: ijnb_v   
     62      INTEGER  :: ijb_u
     63      INTEGER  :: ije_u
     64      INTEGER  :: ijnb_u
     65   
     66      INTEGER  :: ijb_v
     67      INTEGER  :: ije_v
     68      INTEGER  :: ijnb_v
    6969     
    7070   
    71       integer, pointer :: jj_begin_para(:) => NULL()
    72       integer, pointer :: jj_end_para(:) => NULL()
    73       integer, pointer :: jj_nb_para(:) => NULL()
     71      INTEGER, pointer :: jj_begin_para(:) => NULL()
     72      INTEGER, pointer :: jj_end_para(:) => NULL()
     73      INTEGER, pointer :: jj_nb_para(:) => NULL()
    7474    END TYPE distrib 
    7575   
    … …  
    8282 
    8383    SUBROUTINE init_parallel
    84     USE vampir
     84    USE lmdz_vampir
    8585    USE lmdz_mpi
    8686    IMPLICIT NONE
    … …  
    9292      INTEGER :: i,j
    9393      INTEGER :: type_size
    94       integer, dimension(3) :: blocklen,type
     94      INTEGER, DIMENSION(3) :: blocklen,type
    9595      INTEGER :: comp_id
    9696      CHARACTER(LEN=4)  :: num
    … …  
    122122
    123123! Open text output file with mpi_rank in suffix of file name
    124       IF (lunout /= 5 .and. lunout /= 6) THEN
     124      IF (lunout /= 5 .AND. lunout /= 6) THEN
    125125         WRITE(num,'(I4.4)') mpi_rank
    126126         filename='lmdz.out_'//num
    … …  
    138138      do i=0,mpi_size-1
    139139        jj_nb_para(i)=(jjm+1)/mpi_size
    140         if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
    141        
    142         if (jj_nb_para(i) <= 1 ) THEN
     140        IF ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
     141       
     142        IF (jj_nb_para(i) <= 1 ) THEN
    143143         WRITE(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
    144144         WRITE(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
    … …  
    172172      ij_end=jj_end*iip1
    173173     
    174       if (mpi_rank==0) THEN
     174      IF (mpi_rank==0) THEN
    175175        pole_nord=.TRUE.
    176176      else
    … …  
    178178      endif
    179179     
    180       if (mpi_rank==mpi_size-1) THEN
     180      IF (mpi_rank==mpi_size-1) THEN
    181181        pole_sud=.TRUE.
    182182      else
    … …  
    233233      CALL create_distrib(jj_nb_para,current_dist)
    234234     
    235       IF ((mpi_rank==0).and.(omp_rank==0)) THEN
     235      IF ((mpi_rank==0).AND.(omp_rank==0)) THEN
    236236        is_master=.TRUE.
    237237      ELSE
    … …  
    379379    USE lmdz_mpi
    380380    ! ug Pour les sorties XIOS
    381         USE wxios
     381        USE lmdz_wxios
    382382
    383383#ifdef CPP_COUPLE
    384384! Use of Oasis-MCT coupler
    385385#if defined CPP_OMCT
    386     use mod_prism
     386    USE mod_prism
    387387#else
    388     use mod_prism_proto
     388    USE mod_prism_proto
    389389#endif
    390390! Ehouarn: surface_data module is in 'phylmd' ...
    391       use surface_data, ONLY: type_ocean
     391      USE surface_data, ONLY: type_ocean
    392392      IMPLICIT NONE
    393393#else
    … …  
    403403      INTEGER :: i
    404404
    405       if (allocated(jj_begin_para)) deallocate(jj_begin_para)
    406       if (allocated(jj_end_para))   deallocate(jj_end_para)
    407       if (allocated(jj_nb_para))    deallocate(jj_nb_para)
    408 
    409       if (type_ocean == 'couple') THEN
     405      IF (allocated(jj_begin_para)) deallocate(jj_begin_para)
     406      IF (allocated(jj_end_para))   deallocate(jj_end_para)
     407      IF (allocated(jj_nb_para))    deallocate(jj_nb_para)
     408
     409      IF (type_ocean == 'couple') THEN
    410410#ifdef CPP_COUPLE
    411411        IF (using_xios) THEN
    … …  
    413413          CALL wxios_close()
    414414          CALL prism_terminate_proto(ierr)
    415           IF (ierr .ne. PRISM_Ok) THEN
     415          IF (ierr .NE. PRISM_Ok) THEN
    416416            CALL abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
    417417          ENDIF
    418418        ELSE
    419419           CALL prism_terminate_proto(ierr)
    420            IF (ierr .ne. PRISM_Ok) THEN
     420           IF (ierr .NE. PRISM_Ok) THEN
    421421              CALL abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
    422422           endif
    … …  
    441441      INCLUDE "paramet.h"
    442442
    443       integer, intent(in) :: ij,ll,row
    444       real,dimension(ij,ll),intent(in) ::Field
    445       real,dimension(ll*iip1*row), intent(out) :: Buffer
     443      INTEGER, INTENT(IN) :: ij,ll,row
     444      REAL,DIMENSION(ij,ll),INTENT(IN) ::Field
     445      REAL,DIMENSION(ll*iip1*row), INTENT(OUT) :: Buffer
    446446           
    447447      INTEGER :: Pos
    … …  
    464464      INCLUDE "paramet.h"
    465465
    466       integer, intent(in) :: ij,ll,row
    467       real,dimension(ij,ll),intent(out) ::Field
    468       real,dimension(ll*iip1*row), intent(in) :: Buffer
     466      INTEGER, INTENT(IN) :: ij,ll,row
     467      REAL,DIMENSION(ij,ll),INTENT(OUT) ::Field
     468      REAL,DIMENSION(ll*iip1*row), INTENT(IN) :: Buffer
    469469           
    470470      INTEGER :: Pos
    … …  
    497497    SUBROUTINE exchange_hallo(Field,ij,ll,up,down)
    498498    USE lmdz_mpi
    499     USE Vampir
     499    USE lmdz_vampir
    500500    IMPLICIT NONE
    501501      INCLUDE "dimensions.h"
    502502      INCLUDE "paramet.h"   
    503503      INTEGER :: ij,ll
    504       REAL, dimension(ij,ll) :: Field
     504      REAL, DIMENSION(ij,ll) :: Field
    505505      INTEGER :: up,down
    506506     
    … …  
    512512
    513513      INTEGER :: NbRequest
    514       REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
    515       REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
     514      REAL, DIMENSION(:),ALLOCATABLE :: Buffer_Send_up,Buffer_Send_down
     515      REAL, DIMENSION(:),ALLOCATABLE :: Buffer_Recv_up,Buffer_Recv_down
    516516      INTEGER :: Buffer_size     
    517517
    … …  
    537537        ENDIF
    538538       
    539         if (up==0) THEN
     539        IF (up==0) THEN
    540540          SendDown=.FALSE.
    541541          RecvUp=.FALSE.
    542542        endif
    543543     
    544         if (down==0) THEN
     544        IF (down==0) THEN
    545545          SendUp=.FALSE.
    546546          RecvDown=.FALSE.
    … …  
    599599        ENDIF
    600600 
    601         if (NbRequest > 0) CALL MPI_WAITALL(NbRequest,Request,Status,ierr)
     601        IF (NbRequest > 0) CALL MPI_WAITALL(NbRequest,Request,Status,ierr)
    602602        IF (RecvUp)  CALL Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
    603603        IF (RecvDown) CALL Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down)
    … …  
    620620    INCLUDE "iniprint.h"
    621621      INTEGER :: ij,ll,rank
    622       REAL, dimension(ij,ll) :: Field
    623       REAL, dimension(:),allocatable :: Buffer_send   
    624       REAL, dimension(:),allocatable :: Buffer_Recv
    625       INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
     622      REAL, DIMENSION(ij,ll) :: Field
     623      REAL, DIMENSION(:),ALLOCATABLE :: Buffer_send
     624      REAL, DIMENSION(:),ALLOCATABLE :: Buffer_Recv
     625      INTEGER, DIMENSION(0:MPI_Size-1) :: Recv_count, displ
    626626      INTEGER :: ierr
    627627      INTEGER ::i
    … …  
    629629      IF (using_mpi) THEN
    630630
    631         if (ij==ip1jmp1) THEN
     631        IF (ij==ip1jmp1) THEN
    632632           allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
    633633           CALL Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
    634         else if (ij==ip1jm) THEN
     634        ELSE IF (ij==ip1jm) THEN
    635635           allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
    636636           CALL Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
    … …  
    640640        endif
    641641       
    642         if (MPI_Rank==rank) THEN
     642        IF (MPI_Rank==rank) THEN
    643643          allocate(Buffer_Recv(ij*ll))
    644644
    … …  
    646646          do i=0,MPI_Size-1
    647647             
    648             if (ij==ip1jmp1) THEN
     648            IF (ij==ip1jmp1) THEN
    649649              Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
    650             else if (ij==ip1jm) THEN
     650            ELSE IF (ij==ip1jm) THEN
    651651              Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
    652652            else
    … …  
    654654            endif
    655655                   
    656             if (i==0) THEN
     656            IF (i==0) THEN
    657657              displ(i)=0
    658658            else
    … …  
    674674!$OMP END CRITICAL (MPI)
    675675     
    676         if (MPI_Rank==rank) THEN
    677           if (ij==ip1jmp1) THEN
     676        IF (MPI_Rank==rank) THEN
     677          IF (ij==ip1jmp1) THEN
    678678            do i=0,MPI_Size-1
    679679              CALL Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
    680680                               jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
    681681            enddo
    682           else if (ij==ip1jm) THEN
     682          ELSE IF (ij==ip1jm) THEN
    683683            do i=0,MPI_Size-1
    684684               CALL Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
    … …  
    698698    INCLUDE "paramet.h"   
    699699      INTEGER :: ij,ll
    700       REAL, dimension(ij,ll) :: Field
     700      REAL, DIMENSION(ij,ll) :: Field
    701701      INTEGER :: ierr
    702702     
    … …  
    716716    INCLUDE "paramet.h"   
    717717      INTEGER :: ij,ll
    718       REAL, dimension(ij,ll) :: Field
     718      REAL, DIMENSION(ij,ll) :: Field
    719719      INTEGER :: rank
    720720      INTEGER :: ierr
    … …  
    737737
    738738!      INTEGER :: ij,ll
    739 !      REAL, dimension(ij,ll) :: Field
     739!      REAL, DIMENSION(ij,ll) :: Field
    740740!      INTEGER :: up,down
    741741
    742 !      REAL,dimension(ij,ll): NewField
     742!      REAL,DIMENSION(ij,ll): NewField
    743743
    744744!      NewField=0

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/pression_loc.f90

    r5105 r5117  
    2929  ije=ij_end+2*iip1
    3030
    31   if (pole_nord) ijb=ij_begin
    32   if (pole_sud)  ije=ij_end
     31  IF (pole_nord) ijb=ij_begin
     32  IF (pole_sud)  ije=ij_end
    3333
    3434!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/qminimum_loc.f90

    r5116 r5117  
    66  USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, &
    77        isoCheck, min_qParent
    8   USE strings_mod, ONLY: strIdx
    9   USE readTracFiles_mod, ONLY: addPhase
     8  USE lmdz_strings, ONLY: strIdx
     9  USE lmdz_readTracFiles, ONLY: addPhase
    1010  IMPLICIT none
    1111  !
    … …  
    8787!$OMP DO SCHEDULE(STATIC)
    8888    DO i = ijb, ije
    89       if (seuil_liq - q(i,k,iq_liq) > 0.d0 ) THEN
    90         if (niso > 0) zx_defau_diag(i,k,2)=AMAX1 &
     89      IF (seuil_liq - q(i,k,iq_liq) > 0.d0 ) THEN
     90        IF (niso > 0) zx_defau_diag(i,k,2)=AMAX1 &
    9191              ( seuil_liq - q(i,k,iq_liq), 0.0 )
    9292
    … …  
    108108    DO i = ijb, ije
    109109
    110       if ( seuil_vap - q(i,k,iq_vap) > 0.d0 ) THEN
    111         if (niso > 0) zx_defau_diag(i,k,1) &
     110      IF ( seuil_vap - q(i,k,iq_vap) > 0.d0 ) THEN
     111        IF (niso > 0) zx_defau_diag(i,k,1) &
    112112              = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
    113113
    … …  
    148148
    149149  !WRITE(lunout,*) 'qminimum 128'
    150   if (niso > 0) THEN
     150  IF (niso > 0) THEN
    151151          !WRITE(lunout,*) 'qminimum 140'
    152152  ! CRisi: traiter de même les traceurs d'eau
    … …  
    164164!$OMP DO SCHEDULE(STATIC)
    165165  DO i = ijb, ije
    166     if (zx_pump(i)>0.0) THEN
     166    IF (zx_pump(i)>0.0) THEN
    167167      q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
    168168    endif !if (zx_pump(i).gt.0.0) THEN
    … …  
    175175!$OMP DO SCHEDULE(STATIC)
    176176    DO i = ijb, ije
    177       if (zx_defau_diag(i,k,1)>0.0) THEN
     177      IF (zx_defau_diag(i,k,1)>0.0) THEN
    178178          ! on ajoute la vapeur en k
    179179          !  WRITE(lunout,*) 'i,k,q_follow(i,k-1,ivap)=',
    180180  ! :                 i,k,q_follow(i,k-1,1)
    181           if (q_follow(i,k-1,1)<min_qParent) THEN
     181          IF (q_follow(i,k-1,1)<min_qParent) THEN
    182182            WRITE(lunout,*) 'tmp qmin: on stoppe'
    183183            WRITE(lunout,*) 'zx_pump(i)=',zx_pump(i)
    … …  
    200200                 *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
    201201
    202           if (isoCheck) THEN
     202          IF (isoCheck) THEN
    203203            IF(iso_verif_noNaN_nostop(q(i,k,iqIsoPha(ixt,iq_vap)), &
    204204                  'qminimum 155')==1) THEN
    … …  
    224224                 /q_follow(i,k-1,1)
    225225
    226            if (isoCheck) THEN
    227             if (iso_verif_noNaN_nostop( &
     226           IF (isoCheck) THEN
     227            IF (iso_verif_noNaN_nostop( &
    228228                  q(i,k-1,iqIsoPha(ixt,iq_vap)), &
    229229                  'qminimum 175')==1) THEN
    … …  
    260260!$OMP DO SCHEDULE(STATIC)
    261261    DO i = ijb, ije
    262       if (zx_defau_diag(i,k,2)>0.0) THEN
     262      IF (zx_defau_diag(i,k,2)>0.0) THEN
    263263          ! on ajoute eau liquide en k en k
    264264          do ixt=1,ntiso
    … …  
    282282   CALL check_isotopes(q,ijb,ije,'qminimum 197')
    283283
    284   endif !if (niso > 0) THEN
     284  ENDIF !if (niso > 0) THEN
    285285  !WRITE(*,*) 'qminimum 188'
    286286!$OMP BARRIER

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotatf_loc.f90

    r5116 r5117  
    5353    jjb=jj_begin
    5454    jje=jj_end
    55     if (pole_sud) jje=jj_end-1
     55    IF (pole_sud) jje=jj_end-1
    5656    CALL filtreg_p( rot, jjb_v, jje_v,jjb,jje,jjm, &
    5757          klevel, 2, 2, .FALSE., 1 )

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/sw_case_williamson91_6_loc.f90

    r5116 r5117  
    5353  !   ------
    5454
    55   real,allocatable :: ucov_glo(:,:)
    56   real,allocatable :: vcov_glo(:,:)
    57   real,allocatable :: teta_glo(:,:)
    58   real,allocatable :: masse_glo(:,:)
    59   real,allocatable :: ps_glo(:)
     55  REAL,ALLOCATABLE :: ucov_glo(:,:)
     56  REAL,ALLOCATABLE :: vcov_glo(:,:)
     57  REAL,ALLOCATABLE :: teta_glo(:,:)
     58  REAL,ALLOCATABLE :: masse_glo(:,:)
     59  REAL,ALLOCATABLE :: ps_glo(:)
    6060
    6161   ! REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
    … …  
    6565   ! REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
    6666
    67   real,allocatable :: p(:,:)
    68   real,allocatable :: pks(:)
    69   real,allocatable :: pk(:,:)
    70   real,allocatable :: pkf(:,:)
    71   real,allocatable :: alpha(:,:),beta(:,:)
     67  REAL,ALLOCATABLE :: p(:,:)
     68  REAL,ALLOCATABLE :: pks(:)
     69  REAL,ALLOCATABLE :: pk(:,:)
     70  REAL,ALLOCATABLE :: pkf(:,:)
     71  REAL,ALLOCATABLE :: alpha(:,:),beta(:,:)
    7272
    7373  REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps

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

    r5116 r5117  
    11module times
    2   integer,PRIVATE,save :: Last_Count=0
    3   real, PRIVATE,save :: Last_cpuCount=0
     2  INTEGER,PRIVATE,save :: Last_Count=0
     3  REAL, PRIVATE,save :: Last_cpuCount=0
    44  logical, PRIVATE,save :: AllTimer_IsActive=.FALSE.
    55 
    6   integer, parameter :: nb_timer = 4
    7   integer, parameter :: timer_caldyn  = 1
    8   integer, parameter :: timer_vanleer = 2
    9   integer, parameter :: timer_dissip = 3
    10   integer, parameter :: timer_physic = 4
    11   integer, parameter :: stopped = 1
    12   integer, parameter :: running = 2
    13   integer, parameter :: suspended = 3
     6  INTEGER, parameter :: nb_timer = 4
     7  INTEGER, parameter :: timer_caldyn  = 1
     8  INTEGER, parameter :: timer_vanleer = 2
     9  INTEGER, parameter :: timer_dissip = 3
     10  INTEGER, parameter :: timer_physic = 4
     11  INTEGER, parameter :: stopped = 1
     12  INTEGER, parameter :: running = 2
     13  INTEGER, parameter :: suspended = 3
    1414 
    1515  INTEGER :: max_size
    16   real,    allocatable, dimension(:,:,:) :: timer_table
    17   real,    allocatable, dimension(:,:,:) :: timer_table_sqr
    18   integer, allocatable, dimension(:,:,:) :: timer_iteration
    19   real,    allocatable, dimension(:,:,:) :: timer_average
    20   real,    allocatable, dimension(:,:,:) :: timer_delta
    21   real,    allocatable,dimension(:) :: timer_running, last_time
    22   integer, allocatable,dimension(:) :: timer_state
     16  REAL,    ALLOCATABLE, DIMENSION(:,:,:) :: timer_table
     17  REAL,    ALLOCATABLE, DIMENSION(:,:,:) :: timer_table_sqr
     18  INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: timer_iteration
     19  REAL,    ALLOCATABLE, DIMENSION(:,:,:) :: timer_average
     20  REAL,    ALLOCATABLE, DIMENSION(:,:,:) :: timer_delta
     21  REAL,    ALLOCATABLE,DIMENSION(:) :: timer_running, last_time
     22  INTEGER, ALLOCATABLE,DIMENSION(:) :: timer_state
    2323 
    2424  contains
    … …  
    5252    INTEGER :: no_timer
    5353   
    54     if (AllTimer_IsActive) THEN
    55       if (timer_state(no_timer)/=stopped) THEN
     54    IF (AllTimer_IsActive) THEN
     55      IF (timer_state(no_timer)/=stopped) THEN
    5656        CALL abort_gcm("times","start_timer :: timer is already running or suspended",1)
    5757      else
    … …  
    7070    INTEGER :: no_timer
    7171     
    72     if (AllTimer_IsActive) THEN
    73       if (timer_state(no_timer)/=running) THEN
     72    IF (AllTimer_IsActive) THEN
     73      IF (timer_state(no_timer)/=running) THEN
    7474         CALL abort_gcm("times","suspend_timer :: timer is not running",1)
    7575      else
    … …  
    8787    INTEGER :: no_timer
    8888     
    89     if (AllTimer_IsActive) THEN
    90       if (timer_state(no_timer)/=suspended) THEN
     89    IF (AllTimer_IsActive) THEN
     90      IF (timer_state(no_timer)/=suspended) THEN
    9191        CALL abort_gcm("times","resume_timer :: timer is not suspended",1)
    9292      else
    … …  
    106106    REAL :: V,V2
    107107   
    108     if (AllTimer_IsActive) THEN
    109       if (timer_state(no_timer)/=running) THEN
     108    IF (AllTimer_IsActive) THEN
     109      IF (timer_state(no_timer)/=running) THEN
    110110        CALL abort_gcm("times","stop_timer :: timer is not running",1)
    111111      else
    … …  
    121121      timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1
    122122      timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank)
    123       if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) THEN
     123      IF (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) THEN
    124124        N=timer_iteration(jj_nb,no_timer,mpi_rank)
    125125        V2=timer_table_sqr(jj_nb,no_timer,mpi_rank)
    … …  
    140140    INTEGER :: ierr
    141141    INTEGER :: data_size
    142     real, allocatable,dimension(:,:) :: tmp_table
     142    REAL, ALLOCATABLE,DIMENSION(:,:) :: tmp_table
    143143
    144144    IF (using_mpi) THEN   
    145145   
    146       if (AllTimer_IsActive) THEN
     146      IF (AllTimer_IsActive) THEN
    147147      allocate(tmp_table(max_size,nb_timer))
    148148   
    … …  
    167167    INTEGER :: ierr
    168168    INTEGER :: data_size
    169     real, allocatable,dimension(:,:),target :: tmp_table
    170     integer, allocatable,dimension(:,:),target :: tmp_iter
     169    REAL, ALLOCATABLE,DIMENSION(:,:),target :: tmp_table
     170    INTEGER, ALLOCATABLE,DIMENSION(:,:),target :: tmp_iter
    171171    INTEGER :: istats
    172172
    173173    IF (using_mpi) THEN
    174174       
    175       if (AllTimer_IsActive) THEN
     175      IF (AllTimer_IsActive) THEN
    176176      allocate(tmp_table(max_size,nb_timer))
    177177      allocate(tmp_iter(max_size,nb_timer))
    … …  
    197197   
    198198    AllTimer_IsActive=.TRUE.
    199     if (AllTimer_IsActive) THEN
     199    IF (AllTimer_IsActive) THEN
    200200      CALL system_clock(count,count_rate,count_max)
    201201      CALL cpu_time(Last_cpuCount)
    … …  
    210210 
    211211    CALL system_clock(count,count_rate,count_max)
    212     if (Count>=Last_Count) THEN
     212    IF (Count>=Last_Count) THEN
    213213      DiffTime=(1.*(Count-last_Count))/count_rate
    214214    else

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/top_bound_loc.f90

    r5116 r5117  
    6060  !   ----------
    6161
    62   real,intent(inout) :: ucov(iip1,jjb_u:jje_u,llm) ! covariant zonal wind
    63   real,intent(inout) :: vcov(iip1,jjb_v:jje_v,llm) ! covariant meridional wind
    64   real,intent(inout) :: teta(iip1,jjb_u:jje_u,llm) ! potential temperature
    65   real,intent(in) :: masse(iip1,jjb_u:jje_u,llm) ! mass of atmosphere
    66   real,intent(in) :: dt ! time step (s) of sponge model
     62  REAL,INTENT(INOUT) :: ucov(iip1,jjb_u:jje_u,llm) ! covariant zonal wind
     63  REAL,INTENT(INOUT) :: vcov(iip1,jjb_v:jje_v,llm) ! covariant meridional wind
     64  REAL,INTENT(INOUT) :: teta(iip1,jjb_u:jje_u,llm) ! potential temperature
     65  REAL,INTENT(IN) :: masse(iip1,jjb_u:jje_u,llm) ! mass of atmosphere
     66  REAL,INTENT(IN) :: dt ! time step (s) of sponge model
    6767
    6868   ! REAL dv(iip1,jjb_v:jje_v,llm),du(iip1,jjb_u:jje_u,llm)
    … …  
    7878  INTEGER :: i
    7979  REAL,SAVE :: rdamp(llm)
    80   real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
     80  REAL,save :: lambda(llm) ! inverse or quenching time scale (Hz)
    8181  LOGICAL,SAVE :: first=.TRUE.
    8282  INTEGER :: j,l,jjb,jje
    8383
    8484
    85   if (iflag_top_bound == 0) return
    86 
    87   if (first) THEN
     85  IF (iflag_top_bound == 0) return
     86
     87  IF (first) THEN
    8888!$OMP BARRIER
    8989!$OMP MASTER
    90      if (iflag_top_bound == 1) THEN
     90     IF (iflag_top_bound == 1) THEN
    9191  ! sponge quenching over the topmost 4 atmospheric layers
    9292         lambda(:)=0.
    … …  
    9595         lambda(llm-2)=tau_top_bound/4.
    9696         lambda(llm-3)=tau_top_bound/8.
    97      else if (iflag_top_bound == 2) THEN
     97     ELSE IF (iflag_top_bound == 2) THEN
    9898  ! sponge quenching over topmost layers down to pressures which are
    9999  ! higher than 100 times the topmost layer pressure
    … …  
    110110     WRITE(lunout,*)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
    111111     do l=1,llm
    112        if (rdamp(l)/=0.) THEN
     112       IF (rdamp(l)/=0.) THEN
    113113         WRITE(lunout,'(6(1pe12.4,1x))') &
    114114               presnivs(l),log(preff/presnivs(l))*scaleheight, &
    … …  
    119119!$OMP END MASTER
    120120!$OMP BARRIER
    121   endif ! of if (first)
     121  ENDIF ! of if (first)
    122122
    123123
    … …  
    125125
    126126  ! compute zonal average of vcov (or set it to zero)
    127   if (mode_top_bound>=2) THEN
     127  IF (mode_top_bound>=2) THEN
    128128   jjb=jj_begin
    129129   jje=jj_end
    … …  
    150150   enddo
    151151!$OMP END DO NOWAIT
    152   endif ! of if (mode_top_bound.ge.2)
     152  ENDIF ! of if (mode_top_bound.ge.2)
    153153
    154154  ! compute zonal average of u (or set it to zero)
    155   if (mode_top_bound>=2) THEN
     155  IF (mode_top_bound>=2) THEN
    156156   jjb=jj_begin
    157157   jje=jj_end
    … …  
    177177   enddo
    178178!$OMP END DO NOWAIT
    179   endif ! of if (mode_top_bound.ge.2)
     179  ENDIF ! of if (mode_top_bound.ge.2)
    180180
    181181  ! compute zonal average of potential temperature, if necessary
    182   if (mode_top_bound>=3) THEN
     182  IF (mode_top_bound>=3) THEN
    183183   jjb=jj_begin
    184184   jje=jj_end
    … …  
    198198   enddo
    199199!$OMP END DO NOWAIT
    200   endif ! of if (mode_top_bound.ge.3)
    201 
    202   if (mode_top_bound>=1) THEN
     200  ENDIF ! of if (mode_top_bound.ge.3)
     201
     202  IF (mode_top_bound>=1) THEN
    203203   ! Apply sponge quenching on vcov:
    204204   jjb=jj_begin
    … …  
    233233   enddo
    234234!$OMP END DO NOWAIT
    235   endif ! of if (mode_top_bound.ge.1)
    236 
    237   if (mode_top_bound>=3) THEN
     235  ENDIF ! of if (mode_top_bound.ge.1)
     236
     237  IF (mode_top_bound>=3) THEN
    238238   ! Apply sponge quenching on teta:
    239239   jjb=jj_begin
    … …  
    252252   enddo
    253253!$OMP END DO NOWAIT
    254   endif ! of if (mode_top_bond.ge.3)
     254  ENDIF ! of if (mode_top_bond.ge.3)
    255255
    256256END SUBROUTINE top_bound_loc

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlsplt_loc.f90

    r5116 r5117  
    6060  ije = ije_x
    6161
    62   if (pole_nord.and.ijb==1) ijb = ijb + iip1
    63   if (pole_sud.and.ije==ip1jmp1)  ije = ije - iip1
     62  IF (pole_nord.AND.ijb==1) ijb = ijb + iip1
     63  IF (pole_sud.AND.ije==ip1jmp1)  ije = ije - iip1
    6464
    6565  IF (pente_max>-1.e-5) THEN
    … …  
    238238      !   indicage des mailles concernees par le traitement special
    239239      DO ij = ijb, ije
    240         IF(iadvplus(ij, l)==1.and.mod(ij, iip1)/=0) THEN
     240        IF(iadvplus(ij, l)==1.AND.mod(ij, iip1)/=0) THEN
    241241          iju = iju + 1
    242242          indu(iju) = ij
    … …  
    313313        !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    314314        masse(ij, l, iq2) = max(masse(ij, l, iq) * q(ij, l, iq), min_qMass)
    315         if (q(ij, l, iq)>min_qParent) then ! modif 13 nov 2020
     315        IF (q(ij, l, iq)>min_qParent) then ! modif 13 nov 2020
    316316          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
    317317        else
    … …  
    440440  ijb = ij_begin - 2 * iip1
    441441  ije = ij_end + 2 * iip1
    442   if (pole_nord) ijb = ij_begin
    443   if (pole_sud)  ije = ij_end
     442  IF (pole_nord) ijb = ij_begin
     443  IF (pole_sud)  ije = ij_end
    444444
    445445  IF(first) THEN
    … …  
    474474    !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
    475475
    476     if (pole_nord) THEN
     476    IF (pole_nord) THEN
    477477      DO i = 1, iim
    478478        airescb(i) = aire(i + iip1) * q(i + iip1, l, iq)
    … …  
    481481    endif
    482482
    483     if (pole_sud) THEN
     483    IF (pole_sud) THEN
    484484      DO i = 1, iim
    485485        airesch(i) = aire(i + ip1jm - iip1) * q(i + ip1jm - iip1, l, iq)
    … …  
    492492    ijb = ij_begin - 2 * iip1
    493493    ije = ij_end + iip1
    494     if (pole_nord) ijb = ij_begin
    495     if (pole_sud)  ije = ij_end - iip1
     494    IF (pole_nord) ijb = ij_begin
     495    IF (pole_sud)  ije = ij_end - iip1
    496496
    497497    ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1
    … …  
    507507    ijb = ij_begin - iip1
    508508    ije = ij_end + iip1
    509     if (pole_nord) ijb = ij_begin + iip1
    510     if (pole_sud)  ije = ij_end - iip1
     509    IF (pole_nord) ijb = ij_begin + iip1
     510    IF (pole_sud)  ije = ij_end - iip1
    511511
    512512    DO ij = ijb, ije
    … …  
    654654    ijb = ij_begin - iip1
    655655    ije = ij_end + iip1
    656     if (pole_nord) ijb = ij_begin + iip1
    657     if (pole_sud)  ije = ij_end - iip1
     656    IF (pole_nord) ijb = ij_begin + iip1
     657    IF (pole_sud)  ije = ij_end - iip1
    658658
    659659    DO ij = ijb, ije
    … …  
    670670  ijb = ij_begin - iip1
    671671  ije = ij_end
    672   if (pole_nord) ijb = ij_begin
    673   if (pole_sud)  ije = ij_end - iip1
     672  IF (pole_nord) ijb = ij_begin
     673  IF (pole_sud)  ije = ij_end - iip1
    674674
    675675  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    697697  ijbm = ij_begin - iip1
    698698  ijem = ij_end + iip1
    699   if (pole_nord) ijb = ij_begin
    700   if (pole_sud)  ije = ij_end
    701   if (pole_nord) ijbm = ij_begin
    702   if (pole_sud)  ijem = ij_end
     699  IF (pole_nord) ijb = ij_begin
     700  IF (pole_sud)  ije = ij_end
     701  IF (pole_nord) ijbm = ij_begin
     702  IF (pole_sud)  ijem = ij_end
    703703
    704704  do ifils = 1, tracers(iq)%nqDescen
    … …  
    716716      DO ij = ijb, ije
    717717        !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    718         if (q(ij, l, iq)>min_qParent) then ! modif 13 nov 2020
     718        IF (q(ij, l, iq)>min_qParent) then ! modif 13 nov 2020
    719719          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
    720720        else
    … …  
    734734  ijb = ij_begin
    735735  ije = ij_end
    736   if (pole_nord) ijb = ij_begin + iip1
    737   if (pole_sud)  ije = ij_end - iip1
     736  IF (pole_nord) ijb = ij_begin + iip1
     737  IF (pole_sud)  ije = ij_end - iip1
    738738
    739739  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    750750    ENDDO
    751751
    752     if (pole_nord) THEN
     752    IF (pole_nord) THEN
    753753      convpn = SSUM(iim, qbyv(1, l), 1)
    754754      convmpn = ssum(iim, masse_adv_v(1, l), 1)
    … …  
    764764    endif
    765765
    766     if (pole_sud) THEN
     766    IF (pole_sud) THEN
    767767      convps = -SSUM(iim, qbyv(ip1jm - iim, l), 1)
    768768      convmps = -ssum(iim, masse_adv_v(ip1jm - iim, l), 1)
    … …  
    10141014            ! CRisi 24nov2020: ajout d'un message d'erreur clair au lieu d'un plantage
    10151015            ! pour seg fault
    1016             if (lorig(ij, l)==0) THEN
     1016            IF (lorig(ij, l)==0) THEN
    10171017              CALL abort_gcm("vlz in vlsplt_loc", &
    10181018                      "unfixable violation of CFL", 1)
    … …  
    10651065        !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    10661066        masse(ij, l, iq2) = max(masse(ij, l, iq) * q(ij, l, iq), min_qMass)
    1067         if (q(ij, l, iq)>min_qParent) THEN
     1067        IF (q(ij, l, iq)>min_qParent) THEN
    10681068          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
    10691069        else

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

    r5116 r5117  
    2525  USE mod_hallo
    2626  USE write_field_loc, ONLY: WriteField_u, WriteField_v
    27   USE VAMPIR
     27  USE lmdz_vampir
    2828  ! CRisi: on rajoute variables utiles d'infotrac
    2929  USE infotrac, ONLY: nqtot, tracers, isoCheck
    … …  
    9797  ijb = ij_begin - iip1
    9898  ije = ij_end + iip1
    99   if (pole_nord) ijb = ij_begin
    100   if (pole_sud) ije = ij_end
     99  IF (pole_nord) ijb = ij_begin
     100  IF (pole_sud) ije = ij_end
    101101
    102102  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    124124  ijb = ij_begin
    125125  ije = ij_end
    126   if (pole_nord) ijb = ijb + iip1
    127   if (pole_sud)  ije = ije - iip1
     126  IF (pole_nord) ijb = ijb + iip1
     127  IF (pole_sud)  ije = ije - iip1
    128128
    129129  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    137137  ijb = ij_begin - iip1
    138138  ije = ij_end
    139   if (pole_nord) ijb = ij_begin
    140   if (pole_sud)  ije = ij_end - iip1
     139  IF (pole_nord) ijb = ij_begin
     140  IF (pole_sud)  ije = ij_end - iip1
    141141
    142142  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    253253  ijb = ij_begin - 2 * iip1
    254254  ije = ij_end + 2 * iip1
    255   if (pole_nord) ijb = ij_begin
    256   if (pole_sud)  ije = ij_end
     255  IF (pole_nord) ijb = ij_begin
     256  IF (pole_sud)  ije = ij_end
    257257  CALL check_isotopes(zq, ij_begin, ij_end, 'vlspltgen_loc 280')
    258258
    … …  
    290290    ijb = ij_begin - 2 * iip1
    291291    ije = ij_end + 2 * iip1
    292     if (pole_nord) ijb = ij_begin
    293     if (pole_sud)  ije = ij_end
     292    IF (pole_nord) ijb = ij_begin
     293    IF (pole_sud)  ije = ij_end
    294294    CALL check_isotopes(zq, ijb, ije, 'vlspltgen_loc 336')
    295295  END IF

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/vlspltqs_loc.f90

    r5116 r5117  
    5959  ije=ije_x
    6060
    61   if (pole_nord.and.ijb==1) ijb=ijb+iip1
    62   if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
     61  IF (pole_nord.AND.ijb==1) ijb=ijb+iip1
     62  IF (pole_sud.AND.ije==ip1jmp1)  ije=ije-iip1
    6363
    6464  IF (pente_max>-1.e-5) THEN
    … …  
    157157!$OMP END DO NOWAIT
    158158
    159   if (pole_nord) THEN
     159  IF (pole_nord) THEN
    160160!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    161161    DO l=1,llm
    … …  
    163163    ENDDO
    164164!$OMP END DO NOWAIT
    165   endif
    166 
    167   if (pole_sud)  THEN
     165  ENDIF
     166
     167  IF (pole_sud)  THEN
    168168!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    169169    DO l=1,llm
    … …  
    171171    ENDDO
    172172!$OMP END DO NOWAIT
    173   endif
     173  ENDIF
    174174
    175175  !   calcul des flux a gauche et a droite
    … …  
    247247  !   indicage des mailles concernees par le traitement special
    248248           DO ij=ijb,ije
    249               IF(iadvplus(ij,l)==1.and.mod(ij,iip1)/=0) THEN
     249              IF(iadvplus(ij,l)==1.AND.mod(ij,iip1)/=0) THEN
    250250                 iju=iju+1
    251251                 indu(iju)=ij
    … …  
    319319        !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    320320        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    321         if (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
     321        IF (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
    322322          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    323323        else
    … …  
    448448  ijb=ij_begin-2*iip1
    449449  ije=ij_end+2*iip1
    450   if (pole_nord) ijb=ij_begin
    451   if (pole_sud)  ije=ij_end
     450  IF (pole_nord) ijb=ij_begin
     451  IF (pole_sud)  ije=ij_end
    452452  ij=3525
    453453  l=3
    454   if ((ij>=ijb).and.(ij<=ije)) THEN
     454  IF ((ij>=ijb).AND.(ij<=ije)) THEN
    455455    !WRITE(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
    456456  ! &             ij,l,iq,ijb,q(ij,l,:)
    457   endif
     457  ENDIF
    458458
    459459  IF(first) THEN
    … …  
    488488  !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
    489489
    490   if (pole_nord) THEN
     490  IF (pole_nord) THEN
    491491    DO i = 1, iim
    492492      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
    493493    ENDDO
    494494    qpns   = SSUM( iim,  airescb ,1 ) / airej2
    495   endif
    496 
    497   if (pole_sud) THEN
     495  ENDIF
     496
     497  IF (pole_sud) THEN
    498498    DO i = 1, iim
    499499      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    500500    ENDDO
    501501    qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
    502   endif
     502  ENDIF
    503503
    504504
    … …  
    507507  ijb=ij_begin-2*iip1
    508508  ije=ij_end+iip1
    509   if (pole_nord) ijb=ij_begin
    510   if (pole_sud)  ije=ij_end-iip1
     509  IF (pole_nord) ijb=ij_begin
     510  IF (pole_sud)  ije=ij_end-iip1
    511511
    512512  DO ij=ijb,ije
    … …  
    520520  ijb=ij_begin-iip1
    521521  ije=ij_end+iip1
    522   if (pole_nord) ijb=ij_begin+iip1
    523   if (pole_sud)  ije=ij_end-iip1
     522  IF (pole_nord) ijb=ij_begin+iip1
     523  IF (pole_sud)  ije=ij_end-iip1
    524524
    525525  DO ij=ijb,ije
    … …  
    664664  ijb=ij_begin-iip1
    665665  ije=ij_end+iip1
    666   if (pole_nord) ijb=ij_begin+iip1
    667   if (pole_sud)  ije=ij_end-iip1
     666  IF (pole_nord) ijb=ij_begin+iip1
     667  IF (pole_sud)  ije=ij_end-iip1
    668668
    669669  DO ij=ijb,ije
    … …  
    680680  ijb=ij_begin-iip1
    681681  ije=ij_end
    682   if (pole_nord) ijb=ij_begin
    683   if (pole_sud)  ije=ij_end-iip1
     682  IF (pole_nord) ijb=ij_begin
     683  IF (pole_sud)  ije=ij_end-iip1
    684684
    685685!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    708708  ijbm=ij_begin-iip1
    709709  ijem=ij_end+iip1
    710   if (pole_nord) ijb=ij_begin
    711   if (pole_sud)  ije=ij_end
    712   if (pole_nord) ijbm=ij_begin
    713   if (pole_sud)  ijem=ij_end
     710  IF (pole_nord) ijb=ij_begin
     711  IF (pole_sud)  ije=ij_end
     712  IF (pole_nord) ijbm=ij_begin
     713  IF (pole_sud)  ijem=ij_end
    714714
    715715  !WRITE(lunout,*) 'vlspltqs 737: iq,ijb,ije=',iq,ijb,ije
    … …  
    731731        !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    732732        !WRITE(lunout,*) 'ij,l,q(ij,l,iq)=',ij,l,q(ij,l,iq)
    733         if (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
     733        IF (q(ij,l,iq)>min_qParent) then ! modif 13 nov 2020
    734734          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    735735        else
    … …  
    751751  ijb=ij_begin
    752752  ije=ij_end
    753   if (pole_nord) ijb=ij_begin+iip1
    754   if (pole_sud)  ije=ij_end-iip1
     753  IF (pole_nord) ijb=ij_begin+iip1
     754  IF (pole_sud)  ije=ij_end-iip1
    755755
    756756!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/wrgrads.f90

    r5116 r5117  
    2424  INTEGER :: im, jm, lm, i, j, l, iv, iii, iji, iif, ijf
    2525
    26   logical :: writectl
     26  LOGICAL :: writectl
    2727
    2828  writectl = .FALSE.
    … …  
    6363  else
    6464    ivar(if) = mod(ivar(if), nvar(if)) + 1
    65     if (ivar(if)==nvar(if)) THEN
     65    IF (ivar(if)==nvar(if)) THEN
    6666      writectl = .TRUE.
    6767      itime(if) = itime(if) + 1
    … …  
    7777      CALL abort_gcm("wrgrads", "problem", 1)
    7878    endif
    79   endif
     79  ENDIF
    8080
    8181  PRINT*, 'ivar(if),nvar(if),var(ivar(if),if),writectl'
    … …  
    9090                    , i = iii, iif), j = iji, ijf)
    9191  enddo
    92   if (writectl) THEN
     92  IF (writectl) THEN
    9393    file = fichier(if)
    9494    !   WARNING! on reecrase le fichier .ctl a chaque ecriture
    … …  
    118118    close(unit(if))
    119119
    120   endif ! writectl
     120  ENDIF ! writectl
    121121
    122122END SUBROUTINE wrgrads

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

    r5116 r5117  
    1414  SUBROUTINE write_field1D_u(name,Field)
    1515    CHARACTER(LEN=*)   :: name
    16     real, dimension(:) :: Field
     16    REAL, DIMENSION(:) :: Field
    1717
    1818    CALL write_field_u_gen(name,Field,1)
    … …  
    2424     
    2525    CHARACTER(LEN=*)   :: name
    26     real, dimension(:,:) :: Field
     26    REAL, DIMENSION(:,:) :: Field
    2727    INTEGER :: ll
    2828   
    … …  
    3535   SUBROUTINE write_field_u_gen(name,Field,ll)
    3636    USE parallel_lmdz
    37     USE write_field
     37    USE lmdz_write_field
    3838    USE mod_hallo
    3939    IMPLICIT NONE
    … …  
    4242     
    4343    CHARACTER(LEN=*)   :: name
    44     real, dimension(ijb_u:ije_u,ll) :: Field
    45     real, allocatable,SAVE :: New_Field(:,:,:)
    46     integer,dimension(0:mpi_size-1) :: jj_nb_master
     44    REAL, DIMENSION(ijb_u:ije_u,ll) :: Field
     45    REAL, ALLOCATABLE,SAVE :: New_Field(:,:,:)
     46    INTEGER,DIMENSION(0:mpi_size-1) :: jj_nb_master
    4747    type(Request),SAVE :: Request_write
    4848!$OMP THREADPRIVATE(Request_write)
    … …  
    7070
    7171!$OMP MASTER
    72     if (MPI_Rank==0) CALL WriteField(name,New_Field)
     72    IF (MPI_Rank==0) CALL WriteField(name,New_Field)
    7373    DEALLOCATE(New_Field)
    7474!$OMP END MASTER       
    … …  
    7979  SUBROUTINE write_field1D_v(name,Field)
    8080    CHARACTER(LEN=*)   :: name
    81     real, dimension(:) :: Field
     81    REAL, DIMENSION(:) :: Field
    8282
    8383    CALL write_field_v_gen(name,Field,1)
    … …  
    8989     
    9090    CHARACTER(LEN=*)   :: name
    91     real, dimension(:,:) :: Field
     91    REAL, DIMENSION(:,:) :: Field
    9292    INTEGER :: ll
    9393   
    … …  
    100100   SUBROUTINE write_field_v_gen(name,Field,ll)
    101101    USE parallel_lmdz
    102     USE write_field
     102    USE lmdz_write_field
    103103    USE mod_hallo
    104104    IMPLICIT NONE
    … …  
    107107     
    108108    CHARACTER(LEN=*)   :: name
    109     real, dimension(ijb_v:ije_v,ll) :: Field
    110     real, allocatable,SAVE :: New_Field(:,:,:)
    111     integer,dimension(0:mpi_size-1) :: jj_nb_master
     109    REAL, DIMENSION(ijb_v:ije_v,ll) :: Field
     110    REAL, ALLOCATABLE,SAVE :: New_Field(:,:,:)
     111    INTEGER,DIMENSION(0:mpi_size-1) :: jj_nb_master
    112112    type(Request),SAVE :: Request_write
    113113!$OMP THREADPRIVATE(Request_write)   
    … …  
    146146
    147147!$OMP MASTER
    148     if (MPI_Rank==0) CALL WriteField(name,New_Field)
     148    IF (MPI_Rank==0) CALL WriteField(name,New_Field)
    149149    DEALLOCATE(New_Field)
    150150!$OMP END MASTER       

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

    r5116 r5117  
    1010  SUBROUTINE write_field1D_p(name,Field)
    1111    USE parallel_lmdz
    12     USE write_field
     12    USE lmdz_write_field
    1313    IMPLICIT NONE
    1414 
    15     integer, parameter :: MaxDim=1
     15    INTEGER, parameter :: MaxDim=1
    1616    CHARACTER(LEN=*)   :: name
    17     real, dimension(:) :: Field
    18     real, dimension(:),allocatable :: New_Field
    19     integer, dimension(MaxDim) :: Dim
     17    REAL, DIMENSION(:) :: Field
     18    REAL, DIMENSION(:),ALLOCATABLE :: New_Field
     19    INTEGER, DIMENSION(MaxDim) :: Dim
    2020   
    2121   
    … …  
    2525    CALL Gather_Field(New_Field,dim(1),1,0)
    2626   
    27     if (MPI_Rank==0) CALL WriteField(name,New_Field)
     27    IF (MPI_Rank==0) CALL WriteField(name,New_Field)
    2828   
    2929    END SUBROUTINE  write_field1D_p
    … …  
    3131  SUBROUTINE write_field2D_p(name,Field)
    3232    USE parallel_lmdz
    33     USE write_field
     33    USE lmdz_write_field
    3434    IMPLICIT NONE
    3535 
    36     integer, parameter :: MaxDim=2
     36    INTEGER, parameter :: MaxDim=2
    3737    CHARACTER(LEN=*)   :: name
    38     real, dimension(:,:) :: Field
    39     real, dimension(:,:),allocatable :: New_Field
    40     integer, dimension(MaxDim) :: Dim
     38    REAL, DIMENSION(:,:) :: Field
     39    REAL, DIMENSION(:,:),ALLOCATABLE :: New_Field
     40    INTEGER, DIMENSION(MaxDim) :: Dim
    4141   
    4242    Dim=shape(Field)
    … …  
    4545    CALL Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0)
    4646   
    47     if (MPI_Rank==0) CALL WriteField(name,New_Field)
     47    IF (MPI_Rank==0) CALL WriteField(name,New_Field)
    4848   
    4949     
    … …  
    5252  SUBROUTINE write_field3D_p(name,Field)
    5353    USE parallel_lmdz
    54     USE write_field
     54    USE lmdz_write_field
    5555    IMPLICIT NONE
    5656 
    57     integer, parameter :: MaxDim=3
     57    INTEGER, parameter :: MaxDim=3
    5858    CHARACTER(LEN=*)   :: name
    59     real, dimension(:,:,:) :: Field
    60     real, dimension(:,:,:),allocatable :: New_Field
    61     integer, dimension(MaxDim) :: Dim
     59    REAL, DIMENSION(:,:,:) :: Field
     60    REAL, DIMENSION(:,:,:),ALLOCATABLE :: New_Field
     61    INTEGER, DIMENSION(MaxDim) :: Dim
    6262   
    6363    Dim=shape(Field)
    … …  
    6666    CALL Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0)
    6767   
    68    if (MPI_Rank==0) CALL WriteField(name,New_Field)
     68   IF (MPI_Rank==0) CALL WriteField(name,New_Field)
    6969   
    7070  END SUBROUTINE  write_field3D_p

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

    r5116 r5117  
    88  USE misc_mod
    99  USE infotrac, ONLY: nqtot
    10   use com_io_dyn_mod, ONLY: histaveid, histvaveid, histuaveid
     10  USE com_io_dyn_mod, ONLY: histaveid, histvaveid, histuaveid
    1111  USE comconst_mod, ONLY: cpp
    1212  USE temps_mod, ONLY: itau_dyn
    … …  
    4747  REAL phis(ijb_u:ije_u)
    4848  REAL q(ijb_u:ije_u, llm, nqtot)
    49   integer time
     49  INTEGER time
    5050
    5151
    … …  
    5757  REAL, SAVE, ALLOCATABLE :: vnat(:, :), unat(:, :)
    5858  REAL, SAVE, ALLOCATABLE :: vbuffer(:, :)
    59   logical ok_sync
    60   integer itau_w
     59  LOGICAL ok_sync
     60  INTEGER itau_w
    6161  INTEGER :: ijb, ije, jjn
    6262  LOGICAL, SAVE :: first = .TRUE.

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writedynav_loc.f90

    r5116 r5117  
    99  USE misc_mod
    1010  USE infotrac, ONLY: nqtot
    11   use com_io_dyn_mod, ONLY: histaveid, histvaveid, histuaveid
     11  USE com_io_dyn_mod, ONLY: histaveid, histvaveid, histuaveid
    1212  USE comconst_mod, ONLY: cpp
    1313  USE temps_mod, ONLY: itau_dyn
    … …  
    6767  REAL, SAVE, ALLOCATABLE :: tm(:, :)
    6868  REAL, SAVE, ALLOCATABLE :: vnat(:, :), unat(:, :)
    69   logical :: ok_sync
     69  LOGICAL :: ok_sync
    7070  INTEGER :: itau_w
    7171  INTEGER :: ijb, ije, jjn
    … …  
    7676  !  Initialisations
    7777  !
    78   if (adjust) return
     78  IF (adjust) return
    7979
    8080  IF (first) THEN
    … …  
    121121  !
    122122  ije = ij_end
    123   if (pole_sud) jjn = jj_nb - 1
    124   if (pole_sud) ije = ij_end - iip1
     123  IF (pole_sud) jjn = jj_nb - 1
     124  IF (pole_sud) ije = ij_end - iip1
    125125  !$OMP BARRIER
    126126  !$OMP MASTER
    … …  
    209209  !
    210210  !$OMP MASTER
    211   if (ok_sync) THEN
     211  IF (ok_sync) THEN
    212212    CALL histsync(histaveid)
    213213    CALL histsync(histvaveid)

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/writehist_loc.f90

    r5116 r5117  
    66  USE misc_mod
    77  USE infotrac, ONLY: nqtot
    8   use com_io_dyn_mod, ONLY: histid, histvid, histuid
     8  USE com_io_dyn_mod, ONLY: histid, histvid, histuid
    99  USE comconst_mod, ONLY: cpp
    1010  USE temps_mod, ONLY: itau_dyn
    … …  
    6464  REAL, SAVE, ALLOCATABLE :: tm(:, :)
    6565  REAL, SAVE, ALLOCATABLE :: vnat(:, :), unat(:, :)
    66   logical :: ok_sync
     66  LOGICAL :: ok_sync
    6767  INTEGER :: itau_w
    6868  INTEGER :: ijb, ije, jjn
    … …  
    7373  !  Initialisations
    7474  !
    75   if (adjust) return
     75  IF (adjust) return
    7676
    7777  IF (first) THEN
    … …  
    118118  !
    119119  ije = ij_end
    120   if (pole_sud) jjn = jj_nb - 1
    121   if (pole_sud) ije = ij_end - iip1
     120  IF (pole_sud) jjn = jj_nb - 1
     121  IF (pole_sud) ije = ij_end - iip1
    122122  !$OMP BARRIER
    123123  !$OMP MASTER
    … …  
    205205  !
    206206  !$OMP MASTER
    207   if (ok_sync) THEN
     207  IF (ok_sync) THEN
    208208    CALL histsync(histid)
    209209    CALL histsync(histvid)
    210210    CALL histsync(histuid)
    211   endif
     211  ENDIF
    212212  !$OMP END MASTER
    213213END SUBROUTINE writehist_loc
Note: See TracChangeset for help on using the changeset viewer.