Ignore:
Timestamp:
Oct 21, 2024, 2:58:45 PM (23 hours ago)
Author:
abarral
Message:

Convert fixed-form to free-form sources .F -> .{f,F}90
(WIP: some .F remain, will be handled in subsequent commits)

File:
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/trunk/libf/dyn3d/advect.f90

    r5245 r5246  
    22! $Header$
    33!
    4       SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
     4SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
    55
    6       USE comconst_mod, ONLY: daysec
    7       USE logic_mod, ONLY: conser
    8       USE ener_mod, ONLY: gtot
    9      
    10       IMPLICIT NONE
    11 c=======================================================================
    12 c
    13 c   Auteurs:  P. Le Van , Fr. Hourdin  .
    14 c   -------
    15 c
    16 c   Objet:
    17 c   ------
    18 c
    19 c   *************************************************************
    20 c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
    21 c   *************************************************************
    22 c        ces termes sont ajoutes a du,dv,dteta et dq .
    23 c  Modif F.Forget 03/94 : on retire q de advect
    24 c
    25 c=======================================================================
    26 c-----------------------------------------------------------------------
    27 c   Declarations:
    28 c   -------------
     6  USE comconst_mod, ONLY: daysec
     7  USE logic_mod, ONLY: conser
     8  USE ener_mod, ONLY: gtot
    299
    30       include "dimensions.h"
    31       include "paramet.h"
    32       include "comgeom.h"
     10  IMPLICIT NONE
     11  !=======================================================================
     12  !
     13  !   Auteurs:  P. Le Van , Fr. Hourdin  .
     14  !   -------
     15  !
     16  !   Objet:
     17  !   ------
     18  !
     19  !   *************************************************************
     20  !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
     21  !   *************************************************************
     22  !    ces termes sont ajoutes a du,dv,dteta et dq .
     23  !  Modif F.Forget 03/94 : on retire q de advect
     24  !
     25  !=======================================================================
     26  !-----------------------------------------------------------------------
     27  !   Declarations:
     28  !   -------------
    3329
    34 c   Arguments:
    35 c   ----------
     30  include "dimensions.h"
     31  include "paramet.h"
     32  include "comgeom.h"
    3633
    37       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
    38       REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
    39       REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
     34  !   Arguments:
     35  !   ----------
    4036
    41 c   Local:
    42 c   ------
     37  REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
     38  REAL :: massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
     39  REAL :: dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
    4340
    44       REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
    45       REAL unsaire2(ip1jmp1), ge(ip1jmp1)
    46       REAL deuxjour, ww, gt, uu, vv
     41  !   Local:
     42  !   ------
    4743
    48       INTEGER  ij,l
     44  REAL :: uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
     45  REAL :: unsaire2(ip1jmp1), ge(ip1jmp1)
     46  REAL :: deuxjour, ww, gt, uu, vv
    4947
    50       REAL      SSUM
     48  INTEGER :: ij,l
    5149
    52 c-----------------------------------------------------------------------
    53 c   2. Calculs preliminaires:
    54 c   -------------------------
     50  REAL :: SSUM
    5551
    56       IF (conser)  THEN
    57          deuxjour = 2. * daysec
     52  !-----------------------------------------------------------------------
     53  !   2. Calculs preliminaires:
     54  !   -------------------------
    5855
    59          DO   1  ij   = 1, ip1jmp1
    60          unsaire2(ij) = unsaire(ij) * unsaire(ij)
    61    1     CONTINUE
    62       END IF
     56  IF (conser)  THEN
     57     deuxjour = 2. * daysec
     58
     59     DO  ij   = 1, ip1jmp1
     60     unsaire2(ij) = unsaire(ij) * unsaire(ij)
     61     END DO
     62  END IF
    6363
    6464
    65 c------------------  -yy ----------------------------------------------
    66 c   .  Calcul de     u
     65  !------------------  -yy ----------------------------------------------
     66  !   .  Calcul de     u
    6767
    68       DO  l=1,llm
    69          DO    ij     = iip2, ip1jmp1
    70             uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
    71          ENDDO
    72          DO    ij     = iip2, ip1jm
    73             uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
    74          ENDDO
    75          DO      ij         = 1, iip1
    76             uav(ij      ,l) = 0.
    77             uav(ip1jm+ij,l) = 0.
    78          ENDDO
    79       ENDDO
     68  DO  l=1,llm
     69     DO    ij     = iip2, ip1jmp1
     70        uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
     71     ENDDO
     72     DO    ij     = iip2, ip1jm
     73        uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
     74     ENDDO
     75     DO      ij         = 1, iip1
     76        uav(ij      ,l) = 0.
     77        uav(ip1jm+ij,l) = 0.
     78     ENDDO
     79  ENDDO
    8080
    81 c------------------  -xx ----------------------------------------------
    82 c   .  Calcul de     v
     81  !------------------  -xx ----------------------------------------------
     82  !   .  Calcul de     v
    8383
    84       DO  l=1,llm
    85          DO    ij   = 2, ip1jm
    86           vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
    87          ENDDO
    88          DO    ij   = 1,ip1jm,iip1
    89           vav(ij,l) = vav(ij+iim,l)
    90          ENDDO
    91          DO    ij   = 1, ip1jm-1
    92           vav(ij,l) = vav(ij,l) + vav(ij+1,l)
    93          ENDDO
    94          DO    ij       = 1, ip1jm, iip1
    95           vav(ij+iim,l) = vav(ij,l)
    96          ENDDO
    97       ENDDO
     84  DO  l=1,llm
     85     DO    ij   = 2, ip1jm
     86      vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
     87     ENDDO
     88     DO    ij   = 1,ip1jm,iip1
     89      vav(ij,l) = vav(ij+iim,l)
     90     ENDDO
     91     DO    ij   = 1, ip1jm-1
     92      vav(ij,l) = vav(ij,l) + vav(ij+1,l)
     93     ENDDO
     94     DO    ij       = 1, ip1jm, iip1
     95      vav(ij+iim,l) = vav(ij,l)
     96     ENDDO
     97  ENDDO
    9898
    99 c-----------------------------------------------------------------------
     99  !-----------------------------------------------------------------------
    100100
    101 c
    102       DO 20 l = 1, llmm1
     101  !
     102  DO l = 1, llmm1
    103103
    104104
    105 c      ......   calcul de  - w/2.    au niveau  l+1   .......
     105    ! ......   calcul de  - w/2.    au niveau  l+1   .......
    106106
    107       DO 5   ij   = 1, ip1jmp1
    108       wsur2( ij ) = - 0.5 * w( ij,l+1 )
    109    5  CONTINUE
     107  DO   ij   = 1, ip1jmp1
     108  wsur2( ij ) = - 0.5 * w( ij,l+1 )
     109  END DO
    110110
    111111
    112 c    .....................     calcul pour  du     ..................
     112  ! .....................     calcul pour  du     ..................
    113113
    114       DO 6 ij = iip2 ,ip1jm-1
    115       ww        = wsur2 (  ij  )     + wsur2( ij+1 )
    116       uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
    117       du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
    118       du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
    119    6  CONTINUE
     114  DO ij = iip2 ,ip1jm-1
     115  ww        = wsur2 (  ij  )     + wsur2( ij+1 )
     116  uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
     117  du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
     118  du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
     119  END DO
    120120
    121 c    .....  correction pour  du(iip1,j,l)  ........
    122 c    .....     du(iip1,j,l)= du(1,j,l)   .....
     121  ! .....  correction pour  du(iip1,j,l)  ........
     122  ! .....     du(iip1,j,l)= du(1,j,l)   .....
    123123
    124 CDIR$ IVDEP
    125       DO   7  ij   = iip1 +iip1, ip1jm, iip1
    126       du( ij, l  ) = du( ij -iim, l  )
    127       du( ij,l+1 ) = du( ij -iim,l+1 )
    128    7  CONTINUE
     124  !DIR$ IVDEP
     125  DO  ij   = iip1 +iip1, ip1jm, iip1
     126  du( ij, l  ) = du( ij -iim, l  )
     127  du( ij,l+1 ) = du( ij -iim,l+1 )
     128  END DO
    129129
    130 c    .................    calcul pour   dv      .....................
     130  ! .................    calcul pour   dv      .....................
    131131
    132       DO 8 ij = 1, ip1jm
    133       ww        = wsur2( ij+iip1 )   + wsur2( ij )
    134       vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
    135       dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
    136       dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
    137    8  CONTINUE
     132  DO ij = 1, ip1jm
     133  ww        = wsur2( ij+iip1 )   + wsur2( ij )
     134  vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
     135  dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
     136  dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
     137  END DO
    138138
    139 c
     139  !
    140140
    141 c    ............................................................
    142 c    ...............    calcul pour   dh      ...................
    143 c    ............................................................
     141  ! ............................................................
     142  ! ...............    calcul pour   dh      ...................
     143  ! ............................................................
    144144
    145 c                       ---z
    146 c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
    147 c                   ...............
     145  !                   ---z
     146  !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
     147  !               ...............
    148148
    149         DO 15 ij = 1, ip1jmp1
    150          ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
    151          dteta(ij, l ) = dteta(ij, l )  -  ww
    152          dteta(ij,l+1) = dteta(ij,l+1)  +  ww
    153   15    CONTINUE
     149    DO ij = 1, ip1jmp1
     150     ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
     151     dteta(ij, l ) = dteta(ij, l )  -  ww
     152     dteta(ij,l+1) = dteta(ij,l+1)  +  ww
     153    END DO
    154154
    155       IF( conser)  THEN
    156         DO 17 ij = 1,ip1jmp1
    157         ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
    158   17    CONTINUE
    159         gt       = SSUM( ip1jmp1,ge,1 )
    160         gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
    161       END IF
     155  IF( conser)  THEN
     156    DO ij = 1,ip1jmp1
     157    ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
     158    END DO
     159    gt       = SSUM( ip1jmp1,ge,1 )
     160    gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
     161  END IF
    162162
    163   20  CONTINUE
    164  
    165       RETURN
    166       END
     163  END DO
     164
     165  RETURN
     166END SUBROUTINE advect
Note: See TracChangeset for help on using the changeset viewer.