Ignore:
Timestamp:
Mar 5, 2014, 2:19:12 PM (11 years ago)
Author:
lguez
Message:

Converted to free source form files in libf/phylmd which were still in
fixed source form. The conversion was done using the polish mode of
the NAG Fortran Compiler.

In addition to converting to free source form, the processing of the
files also:

-- indented the code (including comments);

-- set Fortran keywords to uppercase, and set all other identifiers
to lower case;

-- added qualifiers to end statements (for example "end subroutine
conflx", instead of "end");

-- changed the terminating statements of all DO loops so that each
loop ends with an ENDDO statement (instead of a labeled continue).

-- replaced #include by include.

File:
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ5/trunk/libf/phylmd/cv3_vertmix.F90

    r1988 r1992  
    1       SUBROUTINE cv3_vertmix(len,nd,iflag,plim1,plim2,p,ph,t,q,u,v
    2      :                     ,w,wi,nk,tmix,thmix,qmix,qsmix
    3      :                     ,umix,vmix,plcl)
    4 ***************************************************************
    5 *                                                             *
    6 * CV3_VERTMIX   Brassage adiabatique d'une couche d'epaisseur *
    7 *               arbitraire.                                   *
    8 *                                                             *
    9 * written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24    *
    10 * modified by :  Filiberti M-A 06/2005 vectorisation          *
    11 ***************************************************************
    12 *
    13        implicit none
    14 C==============================================================
    15 C
    16 C vertmix : determine theta et r du melange obtenu en brassant
    17 C adiabatiquement entre plim1 et plim2, avec une ponderation w.
    18 C
    19 C===============================================================
     1SUBROUTINE cv3_vertmix(len, nd, iflag, plim1, plim2, p, ph, t, q, u, v, w, &
     2    wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
     3  ! **************************************************************
     4  ! *
     5  ! CV3_VERTMIX   Brassage adiabatique d'une couche d'epaisseur *
     6  ! arbitraire.                                   *
     7  ! *
     8  ! written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24    *
     9  ! modified by :  Filiberti M-A 06/2005 vectorisation          *
     10  ! **************************************************************
    2011
    21       include "cvthermo.h"
    22       include "YOETHF.h"
    23       include "YOMCST.h"
    24       include "FCTTRE.h"
    25 c input :
    26       integer nd,len
    27       integer nk(len),iflag(len)
    28       real t(len,nd),q(len,nd),w(nd)
    29       real u(len,nd),v(len,nd)
    30       real p(len,nd),ph(len,nd+1)
    31       real plim1(len),plim2(len)
    32 c output :
    33       real tmix(len),thmix(len),qmix(len),wi(len,nd)
    34       real umix(len),vmix(len)
    35       real qsmix(len)
    36       real plcl(len)
    37 c internal variables :
    38       integer j1(len),j2(len),niflag7
    39       real A,B
    40       real ahm(len),dpw(len),coef(len)
    41       real p1(len,nd),p2(len,nd)
    42       real rdcp(len),a2(len),b2(len),pnk(len)
    43       real rh(len),chi(len)
    44       real cpn
    45       real x,y,p0,p0m1,zdelta,zcor
     12  IMPLICIT NONE
     13  ! ==============================================================
    4614
    47       integer i,j
     15  ! vertmix : determine theta et r du melange obtenu en brassant
     16  ! adiabatiquement entre plim1 et plim2, avec une ponderation w.
    4817
    49       do j = 1,nd
    50         do i=1,len
    51           if (plim1(i).le.ph(i,j)) j1(i) = j
    52           if (plim2(i).ge.ph(i,j+1).and.plim2(i).lt.ph(i,j)) j2(i) = j
    53         enddo
    54       enddo
    55 c
    56       do j=1,nd
    57         do i = 1,len
    58           wi(i,j) = 0.
    59         enddo
    60       enddo
    61       do i = 1,len
    62        ahm(i)=0.
    63        qmix(i)=0.
    64        umix(i)=0.
    65        vmix(i)=0.
    66        dpw(i) =0.
    67        a2(i)=0.0
    68        b2(i) = 0.
    69        pnk(i) = p(i,nk(i))
    70       enddo
    71 c
    72       p0 = 1000.
    73       p0m1 = 1./p0
    74 c
    75       do i=1,len
    76         coef(i) = 1./(plim1(i)-plim2(i))
    77       end do
    78 c
    79       do  j=1,nd
    80         do i=1,len
    81           if (j.ge.j1(i).and.j.le.j2(i)) then
    82             p1(i,j) = min(ph(i,j),plim1(i))
    83             p2(i,j) = max(ph(i,j+1),plim2(i))
    84 cCRtest:couplage thermiques: deja normalise
    85 c             wi(i,j) = w(j)
    86 c             print*,'wi',wi(i,j)
    87             wi(i,j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)
    88             dpw(i) = dpw(i)+wi(i,j)
    89           endif
    90         end do
    91       end do
    92 cCR:print
    93 c      do i=1,len
    94 c         print*,'plim',plim1(i),plim2(i)
    95 c      enddo
    96       do  j=1,nd
    97         do i=1,len
    98           if (j.ge.j1(i).and.j.le.j2(i)) then
    99             wi(i,j)=wi(i,j)/dpw(i)
    100             ahm(i)=ahm(i)+(cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i,j)*wi(i,j)
    101             qmix(i)=qmix(i)+q(i,j)*wi(i,j)
    102             umix(i)=umix(i)+u(i,j)*wi(i,j)
    103             vmix(i)=vmix(i)+v(i,j)*wi(i,j)
    104           endif
    105         end do
    106       end do
    107 c
    108       do i=1,len
    109          rdcp(i)=(rrd*(1.-qmix(i))+qmix(i)*rrv)/
    110      :            (cpd*(1.-qmix(i))+qmix(i)*cpv)
    111       end do
    112 c
     18  ! ===============================================================
    11319
    114 c
    115       do 20 j=1,nd
    116         do 18 i=1,len
    117           if (j.ge.j1(i).and.j.le.j2(i)) then
    118 cc            x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i)
    119             y=(.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i)
    120 cc            a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j)
    121             b2(i)=b2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i,j)
    122           endif
    123    18  continue
    124    20  continue
    125 c
    126        do i=1,len
    127          tmix(i) = ahm(i)/b2(i)
    128          thmix(i) =tmix(i)*(p0/pnk(i))**rdcp(i)
    129 c         print*,'thmix ahm',ahm(i),b2(i)
    130 c         print*,'thmix t',tmix(i),p0
    131 c         print*,'thmix p',pnk(i),rdcp(i)
    132 c         print*,'thmix',thmix(i)
    133 cc         thmix(i) = ahm(i)/a2(i)
    134 cc         tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i)
    135          zdelta=max(0.,sign(1.,rtt-tmix(i)))
    136          qsmix(i)= r2es*FOEEW(tmix(i),zdelta)/(pnk(i)*100.)
    137          qsmix(i)=min(0.5,qsmix(i))
    138          zcor=1./(1.-retv*qsmix(i))
    139          qsmix(i)=qsmix(i)*zcor
    140        end do
    141 c
    142 !-------------------------------------------------------------------
    143 ! --- Calculate lifted condensation level of air at parcel origin level
    144 ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
    145 !-------------------------------------------------------------------
     20  include "cvthermo.h"
     21  include "YOETHF.h"
     22  include "YOMCST.h"
     23  include "FCTTRE.h"
     24  ! input :
     25  INTEGER nd, len
     26  INTEGER nk(len), iflag(len)
     27  REAL t(len, nd), q(len, nd), w(nd)
     28  REAL u(len, nd), v(len, nd)
     29  REAL p(len, nd), ph(len, nd+1)
     30  REAL plim1(len), plim2(len)
     31  ! output :
     32  REAL tmix(len), thmix(len), qmix(len), wi(len, nd)
     33  REAL umix(len), vmix(len)
     34  REAL qsmix(len)
     35  REAL plcl(len)
     36  ! internal variables :
     37  INTEGER j1(len), j2(len), niflag7
     38  REAL a, b
     39  REAL ahm(len), dpw(len), coef(len)
     40  REAL p1(len, nd), p2(len, nd)
     41  REAL rdcp(len), a2(len), b2(len), pnk(len)
     42  REAL rh(len), chi(len)
     43  REAL cpn
     44  REAL x, y, p0, p0m1, zdelta, zcor
    14645
    147        A = 1669.0 ! convect3
    148        B = 122.0  ! convect3
     46  INTEGER i, j
     47
     48  DO j = 1, nd
     49    DO i = 1, len
     50      IF (plim1(i)<=ph(i,j)) j1(i) = j
     51      IF (plim2(i)>=ph(i,j+1) .AND. plim2(i)<ph(i,j)) j2(i) = j
     52    END DO
     53  END DO
     54
     55  DO j = 1, nd
     56    DO i = 1, len
     57      wi(i, j) = 0.
     58    END DO
     59  END DO
     60  DO i = 1, len
     61    ahm(i) = 0.
     62    qmix(i) = 0.
     63    umix(i) = 0.
     64    vmix(i) = 0.
     65    dpw(i) = 0.
     66    a2(i) = 0.0
     67    b2(i) = 0.
     68    pnk(i) = p(i, nk(i))
     69  END DO
     70
     71  p0 = 1000.
     72  p0m1 = 1./p0
     73
     74  DO i = 1, len
     75    coef(i) = 1./(plim1(i)-plim2(i))
     76  END DO
     77
     78  DO j = 1, nd
     79    DO i = 1, len
     80      IF (j>=j1(i) .AND. j<=j2(i)) THEN
     81        p1(i, j) = min(ph(i,j), plim1(i))
     82        p2(i, j) = max(ph(i,j+1), plim2(i))
     83        ! CRtest:couplage thermiques: deja normalise
     84        ! wi(i,j) = w(j)
     85        ! print*,'wi',wi(i,j)
     86        wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)
     87        dpw(i) = dpw(i) + wi(i, j)
     88      END IF
     89    END DO
     90  END DO
     91  ! CR:print
     92  ! do i=1,len
     93  ! print*,'plim',plim1(i),plim2(i)
     94  ! enddo
     95  DO j = 1, nd
     96    DO i = 1, len
     97      IF (j>=j1(i) .AND. j<=j2(i)) THEN
     98        wi(i, j) = wi(i, j)/dpw(i)
     99        ahm(i) = ahm(i) + (cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i, j)*wi(i, j)
     100        qmix(i) = qmix(i) + q(i, j)*wi(i, j)
     101        umix(i) = umix(i) + u(i, j)*wi(i, j)
     102        vmix(i) = vmix(i) + v(i, j)*wi(i, j)
     103      END IF
     104    END DO
     105  END DO
     106
     107  DO i = 1, len
     108    rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv)
     109  END DO
    149110
    150111
    151        niflag7=0
    152        do 260 i=1,len
    153112
    154         if (iflag(i).ne.7) then ! modif sb Jun7th 2002
    155 c
    156         rh(i)=qmix(i)/qsmix(i)
    157         chi(i)=tmix(i)/(A-B*rh(i)-tmix(i)) ! convect3
    158 c   ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
    159 c  MASQUE UN PB POTENTIEL
    160         chi(i)=max(chi(i),0.)
    161         rh(i)=max(rh(i),0.)
    162         plcl(i)=pnk(i)*(rh(i)**chi(i))
    163         if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
    164      &   .and.(iflag(i).eq.0))iflag(i)=8
     113  DO j = 1, nd
     114    DO i = 1, len
     115      IF (j>=j1(i) .AND. j<=j2(i)) THEN
     116        ! c            x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i)
     117        y = (.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i)
     118        ! c            a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j)
     119        b2(i) = b2(i) + (cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i, j)
     120      END IF
     121    END DO
     122  END DO
    165123
    166         else
     124  DO i = 1, len
     125    tmix(i) = ahm(i)/b2(i)
     126    thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i)
     127    ! print*,'thmix ahm',ahm(i),b2(i)
     128    ! print*,'thmix t',tmix(i),p0
     129    ! print*,'thmix p',pnk(i),rdcp(i)
     130    ! print*,'thmix',thmix(i)
     131    ! c         thmix(i) = ahm(i)/a2(i)
     132    ! c         tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i)
     133    zdelta = max(0., sign(1.,rtt-tmix(i)))
     134    qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.)
     135    qsmix(i) = min(0.5, qsmix(i))
     136    zcor = 1./(1.-retv*qsmix(i))
     137    qsmix(i) = qsmix(i)*zcor
     138  END DO
    167139
    168           niflag7=niflag7+1
    169           plcl(i)=plim2(i)
    170 c
    171         endif ! iflag=7
     140  ! -------------------------------------------------------------------
     141  ! --- Calculate lifted condensation level of air at parcel origin level
     142  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
     143  ! -------------------------------------------------------------------
    172144
    173 c      print*,'NIFLAG7  =',niflag7
     145  a = 1669.0 ! convect3
     146  b = 122.0 ! convect3
    174147
    175  260   continue
    176148
    177       return
    178       end
     149  niflag7 = 0
     150  DO i = 1, len
    179151
     152    IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
     153
     154      rh(i) = qmix(i)/qsmix(i)
     155      chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3
     156      ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
     157      ! MASQUE UN PB POTENTIEL
     158      chi(i) = max(chi(i), 0.)
     159      rh(i) = max(rh(i), 0.)
     160      plcl(i) = pnk(i)*(rh(i)**chi(i))
     161      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag &
     162        (i) = 8
     163
     164    ELSE
     165
     166      niflag7 = niflag7 + 1
     167      plcl(i) = plim2(i)
     168
     169    END IF ! iflag=7
     170
     171    ! print*,'NIFLAG7  =',niflag7
     172
     173  END DO
     174
     175  RETURN
     176END SUBROUTINE cv3_vertmix
     177
Note: See TracChangeset for help on using the changeset viewer.