Ignore:
Timestamp:
Jul 23, 2024, 3:29:36 PM (8 weeks ago)
Author:
abarral
Message:

Handle CPP_INLANDSIS in lmdz_cppkeys_wrapper.F90
Remove obsolete key wrgrads_thermcell, _ADV_HALO, _ADV_HALLO, isminmax
Remove redundant uses of CPPKEY_INCA (thanks acozic)
Remove obsolete misc/write_field.F90
Remove unused ioipsl_* wrappers
Remove calls to WriteField_u with wrong signature
Convert .F -> .[fF]90
(lint) uppercase fortran operators
[note: 1d and iso still broken - working on it]

File:
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/fluxstokenc.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4       SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
    5      . time_step,itau )
    6 #ifdef CPP_IOIPSL
    7 ! This routine is designed to work with ioipsl
     3SUBROUTINE fluxstokenc(pbaru, pbarv, masse, teta, phi, phis, &
     4        time_step, itau)
     5  ! This routine is designed to work with ioipsl
    86
    9        USE IOIPSL
    10 c
    11 c    Auteur :  F. Hourdin
    12 c
    13 c
    14 ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
    15 c
    16       IMPLICIT NONE
    17 c
    18       include "dimensions.h"
    19       include "paramet.h"
    20       include "comgeom.h"
    21       include "tracstoke.h"
    22       include "iniprint.h"
     7  USE IOIPSL
     8  !
     9  ! Auteur :  F. Hourdin
     10  !
     11  !
     12  !cc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
     13  !
     14  IMPLICIT NONE
     15  !
     16  include "dimensions.h"
     17  include "paramet.h"
     18  include "comgeom.h"
     19  include "tracstoke.h"
     20  include "iniprint.h"
    2321
    24       REAL time_step,t_wrt, t_ops
    25       REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
    26       REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
    27       REAL phis(ip1jmp1)
     22  REAL :: time_step, t_wrt, t_ops
     23  REAL :: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
     24  REAL :: masse(ip1jmp1, llm), teta(ip1jmp1, llm), phi(ip1jmp1, llm)
     25  REAL :: phis(ip1jmp1)
    2826
    29       REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
    30       REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
     27  REAL :: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
     28  REAL :: massem(ip1jmp1, llm), tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
    3129
    32       REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
     30  REAL :: pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
    3331
    34       REAL pbarvst(iip1,jjp1,llm),zistdyn
    35         real dtcum
     32  REAL :: pbarvst(iip1, jjp1, llm), zistdyn
     33  real :: dtcum
    3634
    37       INTEGER iadvtr,ndex(1)
    38       integer nscal
    39       real tst(1),ist(1),istp(1)
    40       INTEGER ij,l,irec,i,j,itau
    41       INTEGER, SAVE :: fluxid, fluxvid,fluxdid
    42  
    43       SAVE iadvtr, massem,pbaruc,pbarvc,irec
    44       SAVE phic,tetac
    45       logical first
    46       save first
    47       data first/.true./
    48       DATA iadvtr/0/
     35  INTEGER :: iadvtr, ndex(1)
     36  integer :: nscal
     37  real :: tst(1), ist(1), istp(1)
     38  INTEGER :: ij, l, irec, i, j, itau
     39  INTEGER, SAVE :: fluxid, fluxvid, fluxdid
     40
     41  SAVE iadvtr, massem, pbaruc, pbarvc, irec
     42  SAVE phic, tetac
     43  logical :: first
     44  save first
     45  data first/.TRUE./
     46  DATA iadvtr/0/
    4947
    5048
    51 c AC initialisations
    52       pbarug(:,:)   = 0.
    53       pbarvg(:,:,:) = 0.
    54       wg(:,:)       = 0.
    55      
     49  ! AC initialisations
     50  pbarug(:, :) = 0.
     51  pbarvg(:, :, :) = 0.
     52  wg(:, :) = 0.
    5653
    57       if(first) then
     54  if(first) then
    5855
    59         CALL initfluxsto( 'fluxstoke',
    60      .  time_step,istdyn* time_step,istdyn* time_step,
    61      .  fluxid,fluxvid,fluxdid)
    62        
    63         ndex(1) = 0
    64         CALL histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
    65         CALL histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
    66        
    67         ndex(1) = 0
    68         nscal = 1
    69         tst(1) = time_step
    70         CALL histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
    71         ist(1)=istdyn
    72         CALL histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
    73         istp(1)= istphy
    74         CALL histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
    75        
    76         first = .false.
     56    CALL initfluxsto('fluxstoke', &
     57            time_step, istdyn * time_step, istdyn * time_step, &
     58            fluxid, fluxvid, fluxdid)
    7759
    78       endif
     60    ndex(1) = 0
     61    CALL histwrite(fluxid, 'phis', 1, phis, iip1 * jjp1, ndex)
     62    CALL histwrite(fluxid, 'aire', 1, aire, iip1 * jjp1, ndex)
     63
     64    ndex(1) = 0
     65    nscal = 1
     66    tst(1) = time_step
     67    CALL histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
     68    ist(1) = istdyn
     69    CALL histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
     70    istp(1) = istphy
     71    CALL histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
     72
     73    first = .FALSE.
     74
     75  endif
     76
     77  IF(iadvtr==0) THEN
     78    phic(:, :) = 0
     79    tetac(:, :) = 0
     80    pbaruc(:, :) = 0
     81    pbarvc(:, :) = 0
     82  ENDIF
     83
     84  !   accumulation des flux de masse horizontaux
     85  DO l = 1, llm
     86    DO ij = 1, ip1jmp1
     87      pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
     88      tetac(ij, l) = tetac(ij, l) + teta(ij, l)
     89      phic(ij, l) = phic(ij, l) + phi(ij, l)
     90    ENDDO
     91    DO ij = 1, ip1jm
     92      pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
     93    ENDDO
     94  ENDDO
     95
     96  !   selection de la masse instantannee des mailles avant le transport.
     97  IF(iadvtr==0) THEN
     98    CALL SCOPY(ip1jmp1 * llm, masse, 1, massem, 1)
     99  ENDIF
     100
     101  iadvtr = iadvtr + 1
    79102
    80103
    81       IF(iadvtr==0) THEN
    82          phic(:,:)=0
    83          tetac(:,:)=0
    84          pbaruc(:,:)=0
    85          pbarvc(:,:)=0
    86       ENDIF
     104  !   Test pour savoir si on advecte a ce pas de temps
     105  IF (iadvtr==istdyn) THEN
     106    !    normalisation
     107    DO l = 1, llm
     108      DO ij = 1, ip1jmp1
     109        pbaruc(ij, l) = pbaruc(ij, l) / REAL(istdyn)
     110        tetac(ij, l) = tetac(ij, l) / REAL(istdyn)
     111        phic(ij, l) = phic(ij, l) / REAL(istdyn)
     112      ENDDO
     113      DO ij = 1, ip1jm
     114        pbarvc(ij, l) = pbarvc(ij, l) / REAL(istdyn)
     115      ENDDO
     116    ENDDO
    87117
    88 c   accumulation des flux de masse horizontaux
    89       DO l=1,llm
    90          DO ij = 1,ip1jmp1
    91             pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
    92             tetac(ij,l) = tetac(ij,l) + teta(ij,l)
    93             phic(ij,l) = phic(ij,l) + phi(ij,l)
    94          ENDDO
    95          DO ij = 1,ip1jm
    96             pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
    97          ENDDO
    98       ENDDO
     118    !   traitement des flux de masse avant advection.
     119    ! 1. calcul de w
     120    ! 2. groupement des mailles pres du pole.
    99121
    100 c   selection de la masse instantannee des mailles avant le transport.
    101       IF(iadvtr==0) THEN
    102          CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
    103       ENDIF
     122    CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
    104123
    105       iadvtr   = iadvtr+1
     124    do l = 1, llm
     125      do j = 1, jjm
     126        do i = 1, iip1
     127          pbarvst(i, j, l) = pbarvg(i, j, l)
     128        enddo
     129      enddo
     130      do i = 1, iip1
     131        pbarvst(i, jjp1, l) = 0.
     132      enddo
     133    enddo
    106134
     135    iadvtr = 0
     136    write(lunout, *)'ITAU auquel on stoke les fluxmasses', itau
    107137
    108 c   Test pour savoir si on advecte a ce pas de temps
    109       IF ( iadvtr==istdyn ) THEN
    110 c    normalisation
    111       DO l=1,llm
    112          DO ij = 1,ip1jmp1
    113             pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
    114             tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
    115             phic(ij,l) = phic(ij,l)/REAL(istdyn)
    116          ENDDO
    117          DO ij = 1,ip1jm
    118             pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
    119          ENDDO
    120       ENDDO
     138    CALL histwrite(fluxid, 'masse', itau, massem, &
     139            iip1 * jjp1 * llm, ndex)
    121140
    122 c   traitement des flux de masse avant advection.
    123 c     1. calcul de w
    124 c     2. groupement des mailles pres du pole.
     141    CALL histwrite(fluxid, 'pbaru', itau, pbarug, &
     142            iip1 * jjp1 * llm, ndex)
    125143
    126         CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
     144    CALL histwrite(fluxvid, 'pbarv', itau, pbarvg, &
     145            iip1 * jjm * llm, ndex)
    127146
    128         do l=1,llm
    129            do j=1,jjm
    130               do i=1,iip1
    131                  pbarvst(i,j,l)=pbarvg(i,j,l)
    132               enddo
    133            enddo
    134            do i=1,iip1
    135               pbarvst(i,jjp1,l)=0.
    136            enddo
    137         enddo
     147    CALL histwrite(fluxid, 'w', itau, wg, &
     148            iip1 * jjp1 * llm, ndex)
    138149
    139          iadvtr=0
    140         write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
    141        
    142         CALL histwrite(fluxid, 'masse', itau, massem,
    143      .               iip1*jjp1*llm, ndex)
    144        
    145         CALL histwrite(fluxid, 'pbaru', itau, pbarug,
    146      .               iip1*jjp1*llm, ndex)
    147        
    148         CALL histwrite(fluxvid, 'pbarv', itau, pbarvg,
    149      .               iip1*jjm*llm, ndex)
    150        
    151         CALL histwrite(fluxid, 'w' ,itau, wg,
    152      .             iip1*jjp1*llm, ndex)
    153        
    154         CALL histwrite(fluxid, 'teta' ,itau, tetac,
    155      .             iip1*jjp1*llm, ndex)
    156        
    157         CALL histwrite(fluxid, 'phi' ,itau, phic,
    158      .             iip1*jjp1*llm, ndex)
    159        
    160 C
     150    CALL histwrite(fluxid, 'teta', itau, tetac, &
     151            iip1 * jjp1 * llm, ndex)
    161152
    162       ENDIF ! if iadvtr.EQ.istdyn
     153    CALL histwrite(fluxid, 'phi', itau, phic, &
     154            iip1 * jjp1 * llm, ndex)
    163155
    164 #else
    165       write(lunout,*)
    166      & 'fluxstokenc: Needs IOIPSL to function'
    167 #endif
    168 ! of #ifdef CPP_IOIPSL
    169       RETURN
    170       END
     156    !
     157
     158  ENDIF ! if iadvtr.EQ.istdyn
     159
     160  RETURN
     161END SUBROUTINE fluxstokenc
Note: See TracChangeset for help on using the changeset viewer.