Changeset 5248 for LMDZ6/trunk


Ignore:
Timestamp:
Oct 21, 2024, 7:05:31 PM (2 months ago)
Author:
abarral
Message:

(cont.) Convert fixed-form to free-form sources .F -> .{f,F}90

Location:
LMDZ6/trunk/libf
Files:
8 moved

Legend:

Unmodified
Added
Removed
  • LMDZ6/trunk/libf/dyn3d/vlsplt.F90

    r5247 r5248  
    1 c
    2 c $Id$
    3 c
    4 
    5       SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq)
    6       USE infotrac, ONLY: nqtot,tracers
    7 c
    8 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    9 c
    10 c    ********************************************************************
    11 c     Shema  d'advection " pseudo amont " .
    12 c    ********************************************************************
    13 c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    14 c
    15 c   pente_max facteur de limitation des pentes: 2 en general
    16 c                                               0 pour un schema amont
    17 c   pbaru,pbarv,w flux de masse en u ,v ,w
    18 c   pdt pas de temps
    19 c
    20 c   --------------------------------------------------------------------
    21       IMPLICIT NONE
    22 c
    23       include "dimensions.h"
    24       include "paramet.h"
    25 
    26 c
    27 c   Arguments:
    28 c   ----------
    29       REAL masse(ip1jmp1,llm),pente_max
    30 c      REAL masse(iip1,jjp1,llm),pente_max
    31       REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
    32       REAL q(ip1jmp1,llm,nqtot)
    33 c      REAL q(iip1,jjp1,llm)
    34       REAL w(ip1jmp1,llm),pdt
    35       INTEGER iq ! CRisi
    36 c
    37 c      Local
    38 c   ---------
    39 c
    40       INTEGER ij,l
    41 c
    42       REAL zm(ip1jmp1,llm,nqtot)
    43       REAL mu(ip1jmp1,llm)
    44       REAL mv(ip1jm,llm)
    45       REAL mw(ip1jmp1,llm+1)
    46       REAL zq(ip1jmp1,llm,nqtot)
    47       REAL zzpbar, zzw
    48       INTEGER ifils,iq2 ! CRisi
    49 
    50       REAL qmin,qmax
    51       DATA qmin,qmax/0.,1.e33/
    52 
    53         zzpbar = 0.5 * pdt
    54         zzw    = pdt
    55       DO l=1,llm
    56         DO ij = iip2,ip1jm
    57             mu(ij,l)=pbaru(ij,l) * zzpbar
    58          ENDDO
    59          DO ij=1,ip1jm
    60             mv(ij,l)=pbarv(ij,l) * zzpbar
    61          ENDDO
    62          DO ij=1,ip1jmp1
    63             mw(ij,l)=w(ij,l) * zzw
    64          ENDDO
     1!
     2! $Id$
     3!
     4
     5SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq)
     6  USE infotrac, ONLY: nqtot,tracers
     7  !
     8  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     9  !
     10  !    ********************************************************************
     11  ! Shema  d'advection " pseudo amont " .
     12  !    ********************************************************************
     13  ! q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     14  !
     15  !   pente_max facteur de limitation des pentes: 2 en general
     16  !                                           0 pour un schema amont
     17  !   pbaru,pbarv,w flux de masse en u ,v ,w
     18  !   pdt pas de temps
     19  !
     20  !   --------------------------------------------------------------------
     21  IMPLICIT NONE
     22  !
     23  include "dimensions.h"
     24  include "paramet.h"
     25
     26  !
     27  !   Arguments:
     28  !   ----------
     29  REAL :: masse(ip1jmp1,llm),pente_max
     30   ! REAL masse(iip1,jjp1,llm),pente_max
     31  REAL :: pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
     32  REAL :: q(ip1jmp1,llm,nqtot)
     33   ! REAL q(iip1,jjp1,llm)
     34  REAL :: w(ip1jmp1,llm),pdt
     35  INTEGER :: iq ! CRisi
     36  !
     37  !  Local
     38  !   ---------
     39  !
     40  INTEGER :: ij,l
     41  !
     42  REAL :: zm(ip1jmp1,llm,nqtot)
     43  REAL :: mu(ip1jmp1,llm)
     44  REAL :: mv(ip1jm,llm)
     45  REAL :: mw(ip1jmp1,llm+1)
     46  REAL :: zq(ip1jmp1,llm,nqtot)
     47  REAL :: zzpbar, zzw
     48  INTEGER :: ifils,iq2 ! CRisi
     49
     50  REAL :: qmin,qmax
     51  DATA qmin,qmax/0.,1.e33/
     52
     53    zzpbar = 0.5 * pdt
     54    zzw    = pdt
     55  DO l=1,llm
     56    DO ij = iip2,ip1jm
     57        mu(ij,l)=pbaru(ij,l) * zzpbar
     58     ENDDO
     59     DO ij=1,ip1jm
     60        mv(ij,l)=pbarv(ij,l) * zzpbar
     61     ENDDO
     62     DO ij=1,ip1jmp1
     63        mw(ij,l)=w(ij,l) * zzw
     64     ENDDO
     65  ENDDO
     66
     67  DO ij=1,ip1jmp1
     68     mw(ij,llm+1)=0.
     69  ENDDO
     70
     71  CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
     72  CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
     73
     74  do ifils=1,tracers(iq)%nqDescen
     75    iq2=tracers(iq)%iqDescen(ifils)
     76    CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
     77  enddo
     78
     79  !print*,'Entree vlx1'
     80  ! call minmaxq(zq,qmin,qmax,'avant vlx     ')
     81  call vlx(zq,pente_max,zm,mu,iq)
     82  !print*,'Sortie vlx1'
     83  ! call minmaxq(zq,qmin,qmax,'apres vlx1    ')
     84
     85  ! print*,'Entree vly1'
     86
     87  call vly(zq,pente_max,zm,mv,iq)
     88  ! call minmaxq(zq,qmin,qmax,'apres vly1     ')
     89  !print*,'Sortie vly1'
     90  call vlz(zq,pente_max,zm,mw,iq)
     91  ! call minmaxq(zq,qmin,qmax,'apres vlz     ')
     92
     93
     94  call vly(zq,pente_max,zm,mv,iq)
     95  ! call minmaxq(zq,qmin,qmax,'apres vly     ')
     96
     97
     98  call vlx(zq,pente_max,zm,mu,iq)
     99  ! call minmaxq(zq,qmin,qmax,'apres vlx2    ')
     100
     101
     102  DO l=1,llm
     103     DO ij=1,ip1jmp1
     104       q(ij,l,iq)=zq(ij,l,iq)
     105     ENDDO
     106     DO ij=1,ip1jm+1,iip1
     107        q(ij+iim,l,iq)=q(ij,l,iq)
     108     ENDDO
     109  ENDDO
     110  ! ! CRisi: aussi pour les fils
     111  do ifils=1,tracers(iq)%nqDescen
     112    iq2=tracers(iq)%iqDescen(ifils)
     113    DO l=1,llm
     114      DO ij=1,ip1jmp1
     115        q(ij,l,iq2)=zq(ij,l,iq2)
    65116      ENDDO
    66 
     117      DO ij=1,ip1jm+1,iip1
     118        q(ij+iim,l,iq2)=q(ij,l,iq2)
     119      ENDDO
     120    ENDDO
     121  enddo
     122
     123  RETURN
     124END SUBROUTINE vlsplt
     125RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
     126  USE infotrac, ONLY : nqtot,tracers, & ! CRisi
     127        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     128
     129  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     130  !
     131  !    ********************************************************************
     132  ! Shema  d'advection " pseudo amont " .
     133  !    ********************************************************************
     134  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     135  !
     136  !
     137  !   --------------------------------------------------------------------
     138  IMPLICIT NONE
     139  !
     140  include "dimensions.h"
     141  include "paramet.h"
     142  include "iniprint.h"
     143  !
     144  !
     145  !   Arguments:
     146  !   ----------
     147  REAL :: masse(ip1jmp1,llm,nqtot),pente_max
     148  REAL :: u_m( ip1jmp1,llm )
     149  REAL :: q(ip1jmp1,llm,nqtot)
     150  INTEGER :: iq ! CRisi
     151  !
     152  !  Local
     153  !   ---------
     154  !
     155  INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
     156  INTEGER :: n0,iadvplus(ip1jmp1,llm),nl(llm)
     157  !
     158  REAL :: new_m,zu_m,zdum(ip1jmp1,llm)
     159   ! REAL sigu(ip1jmp1)
     160  REAL :: dxq(ip1jmp1,llm),dxqu(ip1jmp1)
     161  REAL :: zz(ip1jmp1)
     162  REAL :: adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
     163  REAL :: u_mq(ip1jmp1,llm)
     164
     165  ! ! CRisi
     166  REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
     167  INTEGER :: ifils,iq2 ! CRisi
     168
     169  Logical :: first
     170  SAVE first
     171  DATA first/.true./
     172
     173  !   calcul de la pente a droite et a gauche de la maille
     174
     175
     176  IF (pente_max.gt.-1.e-5) THEN
     177    ! IF (pente_max.gt.10) THEN
     178
     179  !   calcul des pentes avec limitation, Van Leer scheme I:
     180  !   -----------------------------------------------------
     181
     182  !   calcul de la pente aux points u
     183     DO l = 1, llm
     184        DO ij=iip2,ip1jm-1
     185           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
     186        ENDDO
     187        DO ij=iip1+iip1,ip1jm,iip1
     188           dxqu(ij)=dxqu(ij-iim)
     189           ! sigu(ij)=sigu(ij-iim)
     190        ENDDO
     191
     192        DO ij=iip2,ip1jm
     193           adxqu(ij)=abs(dxqu(ij))
     194        ENDDO
     195
     196  !   calcul de la pente maximum dans la maille en valeur absolue
     197
     198        DO ij=iip2+1,ip1jm
     199           dxqmax(ij,l)=pente_max* &
     200                 min(adxqu(ij-1),adxqu(ij))
     201  ! limitation subtile
     202  !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
     203
     204
     205        ENDDO
     206
     207        DO ij=iip1+iip1,ip1jm,iip1
     208           dxqmax(ij-iim,l)=dxqmax(ij,l)
     209        ENDDO
     210
     211        DO ij=iip2+1,ip1jm
     212#ifdef CRAY
     213           dxq(ij,l)= &
     214                 cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
     215#else
     216           IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
     217              dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
     218           ELSE
     219  !   extremum local
     220              dxq(ij,l)=0.
     221           ENDIF
     222#endif
     223           dxq(ij,l)=0.5*dxq(ij,l)
     224           dxq(ij,l)= &
     225                 sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
     226        ENDDO
     227
     228     ENDDO ! l=1,llm
     229  !print*,'Ok calcul des pentes'
     230
     231  ELSE ! (pente_max.lt.-1.e-5)
     232
     233  !   Pentes produits:
     234  !   ----------------
     235
     236     DO l = 1, llm
     237        DO ij=iip2,ip1jm-1
     238           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
     239        ENDDO
     240        DO ij=iip1+iip1,ip1jm,iip1
     241           dxqu(ij)=dxqu(ij-iim)
     242        ENDDO
     243
     244        DO ij=iip2+1,ip1jm
     245           zz(ij)=dxqu(ij-1)*dxqu(ij)
     246           zz(ij)=zz(ij)+zz(ij)
     247           IF(zz(ij).gt.0) THEN
     248              dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
     249           ELSE
     250  !   extremum local
     251              dxq(ij,l)=0.
     252           ENDIF
     253        ENDDO
     254
     255     ENDDO
     256
     257  ENDIF ! (pente_max.lt.-1.e-5)
     258
     259  !   bouclage de la pente en iip1:
     260  !   -----------------------------
     261
     262  DO l=1,llm
     263     DO ij=iip1+iip1,ip1jm,iip1
     264        dxq(ij-iim,l)=dxq(ij,l)
     265     ENDDO
     266     DO ij=1,ip1jmp1
     267        iadvplus(ij,l)=0
     268     ENDDO
     269
     270  ENDDO
     271
     272  ! print*,'Bouclage en iip1'
     273
     274  !   calcul des flux a gauche et a droite
     275
     276#ifdef CRAY
     277
     278  DO l=1,llm
     279   DO ij=iip2,ip1jm-1
     280      zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq), &
     281            1.+u_m(ij,l)/masse(ij+1,l,iq), &
     282            u_m(ij,l))
     283      zdum(ij,l)=0.5*zdum(ij,l)
     284      u_mq(ij,l)=cvmgp( &
     285            q(ij,l,iq)+zdum(ij,l)*dxq(ij,l), &
     286            q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l), &
     287            u_m(ij,l))
     288      u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
     289   ENDDO
     290  ENDDO
     291#else
     292  !   on cumule le flux correspondant a toutes les mailles dont la masse
     293  !   au travers de la paroi pENDant le pas de temps.
     294  !print*,'Cumule ....'
     295
     296  DO l=1,llm
     297   DO ij=iip2,ip1jm-1
     298  ! print*,'masse(',ij,')=',masse(ij,l,iq)
     299      IF (u_m(ij,l).gt.0.) THEN
     300         zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
     301         u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l))
     302      ELSE
     303         zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
     304         u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq) &
     305               -0.5*zdum(ij,l)*dxq(ij+1,l))
     306      ENDIF
     307   ENDDO
     308  ENDDO
     309#endif
     310
     311  ! go to 9999
     312  !   detection des points ou on advecte plus que la masse de la
     313  !   maille
     314  DO l=1,llm
     315     DO ij=iip2,ip1jm-1
     316        IF(zdum(ij,l).lt.0) THEN
     317           iadvplus(ij,l)=1
     318           u_mq(ij,l)=0.
     319        ENDIF
     320     ENDDO
     321  ENDDO
     322  !print*,'Ok test 1'
     323  DO l=1,llm
     324   DO ij=iip1+iip1,ip1jm,iip1
     325      iadvplus(ij,l)=iadvplus(ij-iim,l)
     326   ENDDO
     327  ENDDO
     328  ! print*,'Ok test 2'
     329
     330
     331  !   traitement special pour le cas ou on advecte en longitude plus que le
     332  !   contenu de la maille.
     333  !   cette partie est mal vectorisee.
     334
     335  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
     336
     337  n0=0
     338  DO l=1,llm
     339     nl(l)=0
     340     DO ij=iip2,ip1jm
     341        nl(l)=nl(l)+iadvplus(ij,l)
     342     ENDDO
     343     n0=n0+nl(l)
     344  ENDDO
     345
     346  IF(n0.gt.0) THEN
     347  if (prt_level > 2) PRINT *, &
     348        'Nombre de points pour lesquels on advect plus que le' &
     349        ,'contenu de la maille : ',n0
     350
     351     DO l=1,llm
     352        IF(nl(l).gt.0) THEN
     353           iju=0
     354  !   indicage des mailles concernees par le traitement special
     355           DO ij=iip2,ip1jm
     356              IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
     357                 iju=iju+1
     358                 indu(iju)=ij
     359              ENDIF
     360           ENDDO
     361           niju=iju
     362           ! PRINT*,'niju,nl',niju,nl(l)
     363
     364  !  traitement des mailles
     365           DO iju=1,niju
     366              ij=indu(iju)
     367              j=(ij-1)/iip1+1
     368              zu_m=u_m(ij,l)
     369              u_mq(ij,l)=0.
     370              IF(zu_m.gt.0.) THEN
     371                 ijq=ij
     372                 i=ijq-(j-1)*iip1
     373  !   accumulation pour les mailles completements advectees
     374                 do while(zu_m.gt.masse(ijq,l,iq))
     375                    u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq) &
     376                          *masse(ijq,l,iq)
     377                    zu_m=zu_m-masse(ijq,l,iq)
     378                    i=mod(i-2+iim,iim)+1
     379                    ijq=(j-1)*iip1+i
     380                 ENDDO
     381  !   ajout de la maille non completement advectee
     382                 u_mq(ij,l)=u_mq(ij,l)+zu_m* &
     383                       (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq)) &
     384                       *dxq(ijq,l))
     385              ELSE
     386                 ijq=ij+1
     387                 i=ijq-(j-1)*iip1
     388  !   accumulation pour les mailles completements advectees
     389                 do while(-zu_m.gt.masse(ijq,l,iq))
     390                    u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) &
     391                          *masse(ijq,l,iq)
     392                    zu_m=zu_m+masse(ijq,l,iq)
     393                    i=mod(i,iim)+1
     394                    ijq=(j-1)*iip1+i
     395                 ENDDO
     396  !   ajout de la maille non completement advectee
     397                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- &
     398                       0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
     399              ENDIF
     400           ENDDO
     401        ENDIF
     402     ENDDO
     403  ENDIF  ! n0.gt.0
     404  !9999    continue
     405
     406
     407  !   bouclage en latitude
     408  !print*,'cvant bouclage en latitude'
     409  DO l=1,llm
     410    DO ij=iip1+iip1,ip1jm,iip1
     411       u_mq(ij,l)=u_mq(ij-iim,l)
     412    ENDDO
     413  ENDDO
     414
     415  ! CRisi: appel récursif de l'advection sur les fils.
     416  ! Il faut faire ça avant d'avoir mis à jour q et masse
     417  ! !write(*,*) 'vlsplt 326: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
     418
     419  do ifils=1,tracers(iq)%nqDescen
     420    iq2=tracers(iq)%iqDescen(ifils)
     421    DO l=1,llm
     422      DO ij=iip2,ip1jm
     423        ! ! On a besoin de q et masse seulement entre iip2 et ip1jm
     424        ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     425  !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     426        ! !Mvals: veiller a ce qu'on n'ait pas de denominateur nul
     427        masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     428        if (q(ij,l,iq).gt.min_qParent) then
     429          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     430        else
     431          Ratio(ij,l,iq2)=min_ratio
     432        endif
     433      enddo
     434    enddo
     435  enddo
     436  do ifils=1,tracers(iq)%nqChildren
     437    iq2=tracers(iq)%iqDescen(ifils)
     438    call vlx(Ratio,pente_max,masseq,u_mq,iq2)
     439  enddo
     440  ! end CRisi
     441
     442
     443  !   calcul des tENDances
     444
     445  DO l=1,llm
     446     DO ij=iip2+1,ip1jm
     447        ! !MVals: veiller a ce qu'on ait pas de denominateur nul
     448        new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
     449        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ &
     450              u_mq(ij-1,l)-u_mq(ij,l)) &
     451              /new_m
     452        masse(ij,l,iq)=new_m
     453     ENDDO
     454  !   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
     455     DO ij=iip1+iip1,ip1jm,iip1
     456        q(ij-iim,l,iq)=q(ij,l,iq)
     457        masse(ij-iim,l,iq)=masse(ij,l,iq)
     458     ENDDO
     459  ENDDO
     460
     461  ! ! retablir les fils en rapport de melange par rapport a l'air:
     462  ! ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
     463  ! ! puis on boucle en longitude
     464  do ifils=1,tracers(iq)%nqDescen
     465    iq2=tracers(iq)%iqDescen(ifils)
     466    DO l=1,llm
     467      DO ij=iip2+1,ip1jm
     468        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
     469      enddo
     470      DO ij=iip1+iip1,ip1jm,iip1
     471         q(ij-iim,l,iq2)=q(ij,l,iq2)
     472      enddo ! DO ij=ijb+iip1-1,ije,iip1
     473    enddo !DO l=1,llm
     474  enddo
     475
     476  ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
     477  ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
     478
     479
     480  RETURN
     481END SUBROUTINE vlx
     482RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
     483  USE infotrac, ONLY : nqtot,tracers, & ! CRisi
     484        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     485  !
     486  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     487  !
     488  !    ********************************************************************
     489  ! Shema  d'advection " pseudo amont " .
     490  !    ********************************************************************
     491  ! q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
     492  ! dq         sont des arguments de sortie pour le s-pg ....
     493  !
     494  !
     495  !   --------------------------------------------------------------------
     496  USE comconst_mod, ONLY: pi
     497  IMPLICIT NONE
     498  !
     499  include "dimensions.h"
     500  include "paramet.h"
     501  include "comgeom.h"
     502  !
     503  !
     504  !   Arguments:
     505  !   ----------
     506  REAL :: masse(ip1jmp1,llm,nqtot),pente_max
     507  REAL :: masse_adv_v( ip1jm,llm)
     508  REAL :: q(ip1jmp1,llm,nqtot)
     509  INTEGER :: iq ! CRisi
     510  !
     511  !  Local
     512  !   ---------
     513  !
     514  INTEGER :: i,ij,l
     515  !
     516  REAL :: airej2,airejjm,airescb(iim),airesch(iim)
     517  REAL :: dyq(ip1jmp1,llm),dyqv(ip1jm)
     518  REAL :: adyqv(ip1jm),dyqmax(ip1jmp1)
     519  REAL :: qbyv(ip1jm,llm)
     520
     521  REAL :: qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
     522  ! REAL appn apps
     523  ! REAL newq,oldmasse
     524  LOGICAL :: first
     525  SAVE first
     526
     527  REAL :: convpn,convps,convmpn,convmps
     528  real :: massepn,masseps,qpn,qps
     529  REAL :: sinlon(iip1),sinlondlon(iip1)
     530  REAL :: coslon(iip1),coslondlon(iip1)
     531  SAVE sinlon,coslon,sinlondlon,coslondlon
     532  SAVE airej2,airejjm
     533
     534  REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
     535  INTEGER :: ifils,iq2 ! CRisi
     536
     537  !
     538  !
     539  REAL :: SSUM
     540
     541  DATA first/.true./
     542
     543  ! !write(*,*) 'vly 578: entree, iq=',iq
     544
     545  IF(first) THEN
     546     PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
     547     first=.false.
     548     do i=2,iip1
     549        coslon(i)=cos(rlonv(i))
     550        sinlon(i)=sin(rlonv(i))
     551        coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
     552        sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
     553     ENDDO
     554     coslon(1)=coslon(iip1)
     555     coslondlon(1)=coslondlon(iip1)
     556     sinlon(1)=sinlon(iip1)
     557     sinlondlon(1)=sinlondlon(iip1)
     558     airej2 = SSUM( iim, aire(iip2), 1 )
     559     airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
     560  ENDIF
     561
     562  !
     563  !PRINT*,'CALCUL EN LATITUDE'
     564
     565  DO l = 1, llm
     566  !
     567  !   --------------------------------
     568  !  CALCUL EN LATITUDE
     569  !   --------------------------------
     570
     571  !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
     572  !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
     573  !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
     574
     575  DO i = 1, iim
     576  airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
     577  airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
     578  ENDDO
     579  qpns   = SSUM( iim,  airescb ,1 ) / airej2
     580  qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
     581
     582  !   calcul des pentes aux points v
     583
     584  DO ij=1,ip1jm
     585     dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
     586     adyqv(ij)=abs(dyqv(ij))
     587  ENDDO
     588
     589  !   calcul des pentes aux points scalaires
     590
     591  DO ij=iip2,ip1jm
     592     dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
     593     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
     594     dyqmax(ij)=pente_max*dyqmax(ij)
     595  ENDDO
     596
     597  !   calcul des pentes aux poles
     598
     599  DO ij=1,iip1
     600     dyq(ij,l)=qpns-q(ij+iip1,l,iq)
     601     dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
     602  ENDDO
     603
     604  !   filtrage de la derivee
     605  dyn1=0.
     606  dys1=0.
     607  dyn2=0.
     608  dys2=0.
     609  DO ij=1,iim
     610     dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
     611     dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
     612     dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
     613     dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
     614  ENDDO
     615  DO ij=1,iip1
     616     dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
     617     dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
     618  ENDDO
     619
     620  !   calcul des pentes limites aux poles
     621
     622  goto 8888
     623  fn=1.
     624  fs=1.
     625  DO ij=1,iim
     626     IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
     627        fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
     628     ENDIF
     629  IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
     630     fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
     631     ENDIF
     632  ENDDO
     633  DO ij=1,iip1
     634     dyq(ij,l)=fn*dyq(ij,l)
     635     dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
     636  ENDDO
     6378888   continue
     638  DO ij=1,iip1
     639     dyq(ij,l)=0.
     640     dyq(ip1jm+ij,l)=0.
     641  ENDDO
     642
     643  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     644  !  En memoire de dIFferents tests sur la
     645  !  limitation des pentes aux poles.
     646  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     647  ! PRINT*,dyq(1)
     648  ! PRINT*,dyqv(iip1+1)
     649  ! appn=abs(dyq(1)/dyqv(iip1+1))
     650  ! PRINT*,dyq(ip1jm+1)
     651  ! PRINT*,dyqv(ip1jm-iip1+1)
     652  ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
     653  ! DO ij=2,iim
     654  !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
     655  !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
     656  ! ENDDO
     657  ! appn=min(pente_max/appn,1.)
     658  ! apps=min(pente_max/apps,1.)
     659  !
     660  !
     661  !   cas ou on a un extremum au pole
     662  !
     663  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     664  !    &   appn=0.
     665  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     666  !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     667  !    &   apps=0.
     668  !
     669  !   limitation des pentes aux poles
     670  ! DO ij=1,iip1
     671  !    dyq(ij)=appn*dyq(ij)
     672  !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
     673  ! ENDDO
     674  !
     675  !   test
     676  !  DO ij=1,iip1
     677  !     dyq(iip1+ij)=0.
     678  !     dyq(ip1jm+ij-iip1)=0.
     679  !  ENDDO
     680  !  DO ij=1,ip1jmp1
     681  !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
     682  !  ENDDO
     683  !
     684  ! changement 10 07 96
     685  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     686  !    &   THEN
     687  !    DO ij=1,iip1
     688  !       dyqmax(ij)=0.
     689  !    ENDDO
     690  ! ELSE
     691  !    DO ij=1,iip1
     692  !       dyqmax(ij)=pente_max*abs(dyqv(ij))
     693  !    ENDDO
     694  ! ENDIF
     695  !
     696  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     697  !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     698  !    &THEN
     699  !    DO ij=ip1jm+1,ip1jmp1
     700  !       dyqmax(ij)=0.
     701  !    ENDDO
     702  ! ELSE
     703  !    DO ij=ip1jm+1,ip1jmp1
     704  !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
     705  !    ENDDO
     706  ! ENDIF
     707  !   fin changement 10 07 96
     708  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     709
     710  !   calcul des pentes limitees
     711
     712  DO ij=iip2,ip1jm
     713     IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
     714        dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
     715     ELSE
     716        dyq(ij,l)=0.
     717     ENDIF
     718  ENDDO
     719
     720  ENDDO
     721
     722  ! !write(*,*) 'vly 756'
     723  DO l=1,llm
     724   DO ij=1,ip1jm
     725      IF(masse_adv_v(ij,l).gt.0) THEN
     726          qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)* &
     727                0.5*(1.-masse_adv_v(ij,l) &
     728                /masse(ij+iip1,l,iq))
     729      ELSE
     730          qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)* &
     731                0.5*(1.+masse_adv_v(ij,l) &
     732                /masse(ij,l,iq))
     733      ENDIF
     734      qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
     735   ENDDO
     736  ENDDO
     737
     738  ! CRisi: appel récursif de l'advection sur les fils.
     739  ! Il faut faire ça avant d'avoir mis à jour q et masse
     740  ! !write(*,*) 'vly 689: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
     741
     742  do ifils=1,tracers(iq)%nqDescen
     743    iq2=tracers(iq)%iqDescen(ifils)
     744    DO l=1,llm
    67745      DO ij=1,ip1jmp1
    68          mw(ij,llm+1)=0.
    69       ENDDO
    70            
    71       CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
    72       CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
    73        
    74       do ifils=1,tracers(iq)%nqDescen
    75         iq2=tracers(iq)%iqDescen(ifils)
    76         CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
    77       enddo 
    78 
    79 cprint*,'Entree vlx1'
    80 c       call minmaxq(zq,qmin,qmax,'avant vlx     ')
    81       call vlx(zq,pente_max,zm,mu,iq)
    82 cprint*,'Sortie vlx1'
    83 c       call minmaxq(zq,qmin,qmax,'apres vlx1    ')
    84 
    85 c print*,'Entree vly1'
    86 
    87       call vly(zq,pente_max,zm,mv,iq)
    88 c       call minmaxq(zq,qmin,qmax,'apres vly1     ')
    89 cprint*,'Sortie vly1'
    90       call vlz(zq,pente_max,zm,mw,iq)
    91 c       call minmaxq(zq,qmin,qmax,'apres vlz     ')
    92 
    93 
    94       call vly(zq,pente_max,zm,mv,iq)
    95 c       call minmaxq(zq,qmin,qmax,'apres vly     ')
    96 
    97 
    98       call vlx(zq,pente_max,zm,mu,iq)
    99 c       call minmaxq(zq,qmin,qmax,'apres vlx2    ')
    100        
    101 
    102       DO l=1,llm
    103          DO ij=1,ip1jmp1
    104            q(ij,l,iq)=zq(ij,l,iq)
    105          ENDDO
    106          DO ij=1,ip1jm+1,iip1
    107             q(ij+iim,l,iq)=q(ij,l,iq)
    108          ENDDO
    109       ENDDO
    110       ! CRisi: aussi pour les fils
    111       do ifils=1,tracers(iq)%nqDescen
    112         iq2=tracers(iq)%iqDescen(ifils)
    113         DO l=1,llm
    114           DO ij=1,ip1jmp1
    115             q(ij,l,iq2)=zq(ij,l,iq2)
    116           ENDDO
    117           DO ij=1,ip1jm+1,iip1
    118             q(ij+iim,l,iq2)=q(ij,l,iq2)
    119           ENDDO
    120         ENDDO
     746        ! ! attention, chaque fils doit avoir son masseq, sinon, le 1er
     747        ! ! fils ecrase le masseq de ses freres.
     748        ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     749  !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     750        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     751        masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     752        if (q(ij,l,iq).gt.min_qParent) then
     753          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     754        else
     755          Ratio(ij,l,iq2)=min_ratio
     756        endif
    121757      enddo
    122 
    123       RETURN
    124       END
    125       RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
    126       USE infotrac, ONLY : nqtot,tracers, ! CRisi
    127      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    128 
    129 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    130 c
    131 c    ********************************************************************
    132 c     Shema  d'advection " pseudo amont " .
    133 c    ********************************************************************
    134 c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    135 c
    136 c
    137 c   --------------------------------------------------------------------
    138       IMPLICIT NONE
    139 c
    140       include "dimensions.h"
    141       include "paramet.h"
    142       include "iniprint.h"
    143 c
    144 c
    145 c   Arguments:
    146 c   ----------
    147       REAL masse(ip1jmp1,llm,nqtot),pente_max
    148       REAL u_m( ip1jmp1,llm )
    149       REAL q(ip1jmp1,llm,nqtot)
    150       INTEGER iq ! CRisi
    151 c
    152 c      Local
    153 c   ---------
    154 c
    155       INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
    156       INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
    157 c
    158       REAL new_m,zu_m,zdum(ip1jmp1,llm)
    159 c      REAL sigu(ip1jmp1)
    160       REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
    161       REAL zz(ip1jmp1)
    162       REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
    163       REAL u_mq(ip1jmp1,llm)
    164 
    165       ! CRisi
    166       REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
    167       INTEGER ifils,iq2 ! CRisi
    168 
    169       Logical first
    170       SAVE first
    171       DATA first/.true./
    172 
    173 c   calcul de la pente a droite et a gauche de la maille
    174 
    175 
    176       IF (pente_max.gt.-1.e-5) THEN
    177 c       IF (pente_max.gt.10) THEN
    178 
    179 c   calcul des pentes avec limitation, Van Leer scheme I:
    180 c   -----------------------------------------------------
    181 
    182 c   calcul de la pente aux points u
    183          DO l = 1, llm
    184             DO ij=iip2,ip1jm-1
    185                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    186             ENDDO
    187             DO ij=iip1+iip1,ip1jm,iip1
    188                dxqu(ij)=dxqu(ij-iim)
    189 c              sigu(ij)=sigu(ij-iim)
    190             ENDDO
    191 
    192             DO ij=iip2,ip1jm
    193                adxqu(ij)=abs(dxqu(ij))
    194             ENDDO
    195 
    196 c   calcul de la pente maximum dans la maille en valeur absolue
    197 
    198             DO ij=iip2+1,ip1jm
    199                dxqmax(ij,l)=pente_max*
    200      ,      min(adxqu(ij-1),adxqu(ij))
    201 c limitation subtile
    202 c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
    203          
    204 
    205             ENDDO
    206 
    207             DO ij=iip1+iip1,ip1jm,iip1
    208                dxqmax(ij-iim,l)=dxqmax(ij,l)
    209             ENDDO
    210 
    211             DO ij=iip2+1,ip1jm
     758    enddo
     759  enddo
     760
     761  do ifils=1,tracers(iq)%nqDescen
     762    iq2=tracers(iq)%iqDescen(ifils)
     763    call vly(Ratio,pente_max,masseq,qbyv,iq2)
     764  enddo
     765
     766  DO l=1,llm
     767     DO ij=iip2,ip1jm
     768        newmasse=masse(ij,l,iq) &
     769              +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
     770        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l) &
     771              -qbyv(ij-iip1,l))/newmasse
     772        masse(ij,l,iq)=newmasse
     773     ENDDO
     774  !.-. ancienne version
     775     ! convpn=SSUM(iim,qbyv(1,l),1)/apoln
     776     ! convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
     777
     778     convpn=SSUM(iim,qbyv(1,l),1)
     779     convmpn=ssum(iim,masse_adv_v(1,l),1)
     780     massepn=ssum(iim,masse(1,l,iq),1)
     781     qpn=0.
     782     do ij=1,iim
     783        qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
     784     enddo
     785     qpn=(qpn+convpn)/(massepn+convmpn)
     786     do ij=1,iip1
     787        q(ij,l,iq)=qpn
     788     enddo
     789
     790     ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
     791     ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
     792
     793     convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
     794     convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
     795     masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
     796     qps=0.
     797     do ij = ip1jm+1,ip1jmp1-1
     798        qps=qps+masse(ij,l,iq)*q(ij,l,iq)
     799     enddo
     800     qps=(qps+convps)/(masseps+convmps)
     801     do ij=ip1jm+1,ip1jmp1
     802        q(ij,l,iq)=qps
     803     enddo
     804
     805  !.-. fin ancienne version
     806
     807  !._. nouvelle version
     808     ! convpn=SSUM(iim,qbyv(1,l),1)
     809     ! convmpn=ssum(iim,masse_adv_v(1,l),1)
     810     ! oldmasse=ssum(iim,masse(1,l),1)
     811     ! newmasse=oldmasse+convmpn
     812     ! newq=(q(1,l)*oldmasse+convpn)/newmasse
     813     ! newmasse=newmasse/apoln
     814     ! DO ij = 1,iip1
     815     !    q(ij,l)=newq
     816     !    masse(ij,l,iq)=newmasse*aire(ij)
     817     ! ENDDO
     818     ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
     819     ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
     820     ! oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
     821     ! newmasse=oldmasse+convmps
     822     ! newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
     823     ! newmasse=newmasse/apols
     824     ! DO ij = ip1jm+1,ip1jmp1
     825     !    q(ij,l)=newq
     826     !    masse(ij,l,iq)=newmasse*aire(ij)
     827     ! ENDDO
     828  !._. fin nouvelle version
     829  ENDDO
     830
     831  ! retablir les fils en rapport de melange par rapport a l'air:
     832  do ifils=1,tracers(iq)%nqDescen
     833    iq2=tracers(iq)%iqDescen(ifils)
     834    DO l=1,llm
     835      DO ij=1,ip1jmp1
     836        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
     837      enddo
     838    enddo
     839  enddo
     840
     841  ! !write(*,*) 'vly 853: sortie'
     842
     843  RETURN
     844END SUBROUTINE vly
     845RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
     846  USE infotrac, ONLY : nqtot,tracers, & ! CRisi
     847        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     848  !
     849  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     850  !
     851  !    ********************************************************************
     852  ! Shema  d'advection " pseudo amont " .
     853  !    ********************************************************************
     854  !    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     855  ! dq         sont des arguments de sortie pour le s-pg ....
     856  !
     857  !
     858  !   --------------------------------------------------------------------
     859  IMPLICIT NONE
     860  !
     861  include "dimensions.h"
     862  include "paramet.h"
     863  !
     864  !
     865  !   Arguments:
     866  !   ----------
     867  REAL :: masse(ip1jmp1,llm,nqtot),pente_max
     868  REAL :: q(ip1jmp1,llm,nqtot)
     869  REAL :: w(ip1jmp1,llm+1)
     870  INTEGER :: iq
     871  !
     872  !  Local
     873  !   ---------
     874  !
     875  INTEGER :: ij,l
     876  !
     877  REAL :: wq(ip1jmp1,llm+1),newmasse
     878
     879  REAL :: dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
     880  REAL :: sigw
     881
     882  REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
     883  INTEGER :: ifils,iq2 ! CRisi
     884
     885  LOGICAL :: testcpu
     886  SAVE testcpu
     887
     888#ifdef BIDON
     889  REAL :: temps0,temps1,second
     890  SAVE temps0,temps1
     891
     892  DATA testcpu/.false./
     893  DATA temps0,temps1/0.,0./
     894#endif
     895
     896  !    On oriente tout dans le sens de la pression c'est a dire dans le
     897  !    sens de W
     898
     899  ! !write(*,*) 'vlz 923: entree'
     900
     901#ifdef BIDON
     902  IF(testcpu) THEN
     903     temps0=second(0.)
     904  ENDIF
     905#endif
     906  DO l=2,llm
     907     DO ij=1,ip1jmp1
     908        dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
     909        adzqw(ij,l)=abs(dzqw(ij,l))
     910     ENDDO
     911  ENDDO
     912
     913  DO l=2,llm-1
     914     DO ij=1,ip1jmp1
    212915#ifdef CRAY
    213                dxq(ij,l)=
    214      ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
     916        dzq(ij,l)=0.5* &
     917              cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
    215918#else
    216                IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
    217                   dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
    218                ELSE
    219 c   extremum local
    220                   dxq(ij,l)=0.
    221                ENDIF
     919        IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
     920            dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
     921        ELSE
     922            dzq(ij,l)=0.
     923        ENDIF
    222924#endif
    223                dxq(ij,l)=0.5*dxq(ij,l)
    224                dxq(ij,l)=
    225      ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
    226             ENDDO
    227 
    228          ENDDO ! l=1,llm
    229 cprint*,'Ok calcul des pentes'
    230 
    231       ELSE ! (pente_max.lt.-1.e-5)
    232 
    233 c   Pentes produits:
    234 c   ----------------
    235 
    236          DO l = 1, llm
    237             DO ij=iip2,ip1jm-1
    238                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    239             ENDDO
    240             DO ij=iip1+iip1,ip1jm,iip1
    241                dxqu(ij)=dxqu(ij-iim)
    242             ENDDO
    243 
    244             DO ij=iip2+1,ip1jm
    245                zz(ij)=dxqu(ij-1)*dxqu(ij)
    246                zz(ij)=zz(ij)+zz(ij)
    247                IF(zz(ij).gt.0) THEN
    248                   dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
    249                ELSE
    250 c   extremum local
    251                   dxq(ij,l)=0.
    252                ENDIF
    253             ENDDO
    254 
    255          ENDDO
    256 
    257       ENDIF ! (pente_max.lt.-1.e-5)
    258 
    259 c   bouclage de la pente en iip1:
    260 c   -----------------------------
    261 
    262       DO l=1,llm
    263          DO ij=iip1+iip1,ip1jm,iip1
    264             dxq(ij-iim,l)=dxq(ij,l)
    265          ENDDO
    266          DO ij=1,ip1jmp1
    267             iadvplus(ij,l)=0
    268          ENDDO
    269 
    270       ENDDO
    271 
    272 c print*,'Bouclage en iip1'
    273 
    274 c   calcul des flux a gauche et a droite
    275 
    276 #ifdef CRAY
    277 
    278       DO l=1,llm
    279        DO ij=iip2,ip1jm-1
    280           zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
    281      ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
    282      ,                     u_m(ij,l))
    283           zdum(ij,l)=0.5*zdum(ij,l)
    284           u_mq(ij,l)=cvmgp(
    285      ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
    286      ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
    287      ,                u_m(ij,l))
    288           u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
    289        ENDDO
    290       ENDDO
    291 #else
    292 c   on cumule le flux correspondant a toutes les mailles dont la masse
    293 c   au travers de la paroi pENDant le pas de temps.
    294 cprint*,'Cumule ....'
    295 
    296       DO l=1,llm
    297        DO ij=iip2,ip1jm-1
    298 c       print*,'masse(',ij,')=',masse(ij,l,iq)
    299           IF (u_m(ij,l).gt.0.) THEN
    300              zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
    301              u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l))
    302           ELSE
    303              zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
    304              u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)
    305      &           -0.5*zdum(ij,l)*dxq(ij+1,l))
    306           ENDIF
    307        ENDDO
    308       ENDDO
     925        dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
     926        dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
     927     ENDDO
     928  ENDDO
     929
     930  ! !write(*,*) 'vlz 954'
     931  DO ij=1,ip1jmp1
     932     dzq(ij,1)=0.
     933     dzq(ij,llm)=0.
     934  ENDDO
     935
     936#ifdef BIDON
     937  IF(testcpu) THEN
     938     temps1=temps1+second(0.)-temps0
     939  ENDIF
    309940#endif
    310 
    311 c       go to 9999
    312 c   detection des points ou on advecte plus que la masse de la
    313 c   maille
    314       DO l=1,llm
    315          DO ij=iip2,ip1jm-1
    316             IF(zdum(ij,l).lt.0) THEN
    317                iadvplus(ij,l)=1
    318                u_mq(ij,l)=0.
    319             ENDIF
    320          ENDDO
    321       ENDDO
    322 cprint*,'Ok test 1'
    323       DO l=1,llm
    324        DO ij=iip1+iip1,ip1jm,iip1
    325           iadvplus(ij,l)=iadvplus(ij-iim,l)
    326        ENDDO
    327       ENDDO
    328 c print*,'Ok test 2'
    329 
    330 
    331 c   traitement special pour le cas ou on advecte en longitude plus que le
    332 c   contenu de la maille.
    333 c   cette partie est mal vectorisee.
    334 
    335 c  calcul du nombre de maille sur lequel on advecte plus que la maille.
    336 
    337       n0=0
    338       DO l=1,llm
    339          nl(l)=0
    340          DO ij=iip2,ip1jm
    341             nl(l)=nl(l)+iadvplus(ij,l)
    342          ENDDO
    343          n0=n0+nl(l)
    344       ENDDO
    345 
    346       IF(n0.gt.0) THEN
    347       if (prt_level > 2) PRINT *,
    348      $        'Nombre de points pour lesquels on advect plus que le'
    349      &       ,'contenu de la maille : ',n0
    350 
    351          DO l=1,llm
    352             IF(nl(l).gt.0) THEN
    353                iju=0
    354 c   indicage des mailles concernees par le traitement special
    355                DO ij=iip2,ip1jm
    356                   IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
    357                      iju=iju+1
    358                      indu(iju)=ij
    359                   ENDIF
    360                ENDDO
    361                niju=iju
    362 c              PRINT*,'niju,nl',niju,nl(l)
    363 
    364 c  traitement des mailles
    365                DO iju=1,niju
    366                   ij=indu(iju)
    367                   j=(ij-1)/iip1+1
    368                   zu_m=u_m(ij,l)
    369                   u_mq(ij,l)=0.
    370                   IF(zu_m.gt.0.) THEN
    371                      ijq=ij
    372                      i=ijq-(j-1)*iip1
    373 c   accumulation pour les mailles completements advectees
    374                      do while(zu_m.gt.masse(ijq,l,iq))
    375                         u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
    376      &                          *masse(ijq,l,iq)
    377                         zu_m=zu_m-masse(ijq,l,iq)
    378                         i=mod(i-2+iim,iim)+1
    379                         ijq=(j-1)*iip1+i
    380                      ENDDO
    381 c   ajout de la maille non completement advectee
    382                      u_mq(ij,l)=u_mq(ij,l)+zu_m*
    383      &                  (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq))
    384      &                  *dxq(ijq,l))
    385                   ELSE
    386                      ijq=ij+1
    387                      i=ijq-(j-1)*iip1
    388 c   accumulation pour les mailles completements advectees
    389                      do while(-zu_m.gt.masse(ijq,l,iq))
    390                         u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
    391      &                          *masse(ijq,l,iq)
    392                         zu_m=zu_m+masse(ijq,l,iq)
    393                         i=mod(i,iim)+1
    394                         ijq=(j-1)*iip1+i
    395                      ENDDO
    396 c   ajout de la maille non completement advectee
    397                      u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
    398      &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    399                   ENDIF
    400                ENDDO
    401             ENDIF
    402          ENDDO
    403       ENDIF  ! n0.gt.0
    404 c9999    continue
    405 
    406 
    407 c   bouclage en latitude
    408 cprint*,'cvant bouclage en latitude'
    409       DO l=1,llm
    410         DO ij=iip1+iip1,ip1jm,iip1
    411            u_mq(ij,l)=u_mq(ij-iim,l)
    412         ENDDO
    413       ENDDO
    414 
    415 ! CRisi: appel récursif de l'advection sur les fils.
    416 ! Il faut faire ça avant d'avoir mis à jour q et masse
    417       !write(*,*) 'vlsplt 326: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
    418      
    419       do ifils=1,tracers(iq)%nqDescen
    420         iq2=tracers(iq)%iqDescen(ifils)
    421         DO l=1,llm
    422           DO ij=iip2,ip1jm
    423             ! On a besoin de q et masse seulement entre iip2 et ip1jm
    424             !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    425             !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    426             !Mvals: veiller a ce qu'on n'ait pas de denominateur nul
    427             masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    428             if (q(ij,l,iq).gt.min_qParent) then
    429               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    430             else
    431               Ratio(ij,l,iq2)=min_ratio
    432             endif
    433           enddo   
    434         enddo
     941  ! ---------------------------------------------------------------
     942  !   .... calcul des termes d'advection verticale  .......
     943  ! ---------------------------------------------------------------
     944
     945  ! calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
     946
     947   ! !write(*,*) 'vlz 969'
     948   DO l = 1,llm-1
     949     do  ij = 1,ip1jmp1
     950      IF(w(ij,l+1).gt.0.) THEN
     951         sigw=w(ij,l+1)/masse(ij,l+1,iq)
     952         wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq) &
     953               +0.5*(1.-sigw)*dzq(ij,l+1))
     954      ELSE
     955         sigw=w(ij,l+1)/masse(ij,l,iq)
     956         wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l))
     957      ENDIF
     958     ENDDO
     959   ENDDO
     960
     961   DO ij=1,ip1jmp1
     962      wq(ij,llm+1)=0.
     963      wq(ij,1)=0.
     964   ENDDO
     965
     966  ! CRisi: appel récursif de l'advection sur les fils.
     967  ! Il faut faire ça avant d'avoir mis à jour q et masse
     968  ! !write(*,*) 'vlsplt 942: iq,nqChildren(iq)=',iq,nqChildren(iq)
     969  do ifils=1,tracers(iq)%nqDescen
     970    iq2=tracers(iq)%iqDescen(ifils)
     971    DO l=1,llm
     972      DO ij=1,ip1jmp1
     973        ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     974  !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     975        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     976        masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     977        if (q(ij,l,iq).gt.min_qParent) then
     978          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     979        else
     980          Ratio(ij,l,iq2)=min_ratio
     981        endif
    435982      enddo
    436       do ifils=1,tracers(iq)%nqChildren
    437         iq2=tracers(iq)%iqDescen(ifils)
    438         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
     983    enddo
     984  enddo
     985
     986  do ifils=1,tracers(iq)%nqChildren
     987    iq2=tracers(iq)%iqDescen(ifils)
     988    call vlz(Ratio,pente_max,masseq,wq,iq2)
     989  enddo
     990  ! end CRisi
     991
     992  DO l=1,llm
     993     DO ij=1,ip1jmp1
     994        newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l)
     995        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l)) &
     996              /newmasse
     997        masse(ij,l,iq)=newmasse
     998     ENDDO
     999  ENDDO
     1000
     1001  ! retablir les fils en rapport de melange par rapport a l'air:
     1002  do ifils=1,tracers(iq)%nqDescen
     1003    iq2=tracers(iq)%iqDescen(ifils)
     1004    DO l=1,llm
     1005      DO ij=1,ip1jmp1
     1006        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
    4391007      enddo
    440 ! end CRisi
    441 
    442 
    443 c   calcul des tENDances
    444 
    445       DO l=1,llm
    446          DO ij=iip2+1,ip1jm
    447             !MVals: veiller a ce qu'on ait pas de denominateur nul
    448             new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
    449             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
    450      &      u_mq(ij-1,l)-u_mq(ij,l))
    451      &      /new_m
    452             masse(ij,l,iq)=new_m
    453          ENDDO
    454 c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
    455          DO ij=iip1+iip1,ip1jm,iip1
    456             q(ij-iim,l,iq)=q(ij,l,iq)
    457             masse(ij-iim,l,iq)=masse(ij,l,iq)
    458          ENDDO
    459       ENDDO
    460 
    461       ! retablir les fils en rapport de melange par rapport a l'air:
    462       ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
    463       ! puis on boucle en longitude
    464       do ifils=1,tracers(iq)%nqDescen
    465         iq2=tracers(iq)%iqDescen(ifils)
    466         DO l=1,llm
    467           DO ij=iip2+1,ip1jm
    468             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    469           enddo
    470           DO ij=iip1+iip1,ip1jm,iip1
    471              q(ij-iim,l,iq2)=q(ij,l,iq2)
    472           enddo ! DO ij=ijb+iip1-1,ije,iip1
    473         enddo !DO l=1,llm
    474       enddo
    475 
    476 c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    477 c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
    478 
    479 
    480       RETURN
    481       END
    482       RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
    483       USE infotrac, ONLY : nqtot,tracers, ! CRisi
    484      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    485 c
    486 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    487 c
    488 c    ********************************************************************
    489 c     Shema  d'advection " pseudo amont " .
    490 c    ********************************************************************
    491 c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
    492 c     dq               sont des arguments de sortie pour le s-pg ....
    493 c
    494 c
    495 c   --------------------------------------------------------------------
    496       USE comconst_mod, ONLY: pi
    497       IMPLICIT NONE
    498 c
    499       include "dimensions.h"
    500       include "paramet.h"
    501       include "comgeom.h"
    502 c
    503 c
    504 c   Arguments:
    505 c   ----------
    506       REAL masse(ip1jmp1,llm,nqtot),pente_max
    507       REAL masse_adv_v( ip1jm,llm)
    508       REAL q(ip1jmp1,llm,nqtot)
    509       INTEGER iq ! CRisi
    510 c
    511 c      Local
    512 c   ---------
    513 c
    514       INTEGER i,ij,l
    515 c
    516       REAL airej2,airejjm,airescb(iim),airesch(iim)
    517       REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
    518       REAL adyqv(ip1jm),dyqmax(ip1jmp1)
    519       REAL qbyv(ip1jm,llm)
    520 
    521       REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
    522 c     REAL appn apps
    523 c     REAL newq,oldmasse
    524       LOGICAL first
    525       SAVE first
    526 
    527       REAL convpn,convps,convmpn,convmps
    528       real massepn,masseps,qpn,qps
    529       REAL sinlon(iip1),sinlondlon(iip1)
    530       REAL coslon(iip1),coslondlon(iip1)
    531       SAVE sinlon,coslon,sinlondlon,coslondlon
    532       SAVE airej2,airejjm
    533 
    534       REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    535       INTEGER ifils,iq2 ! CRisi
    536 
    537 c
    538 c
    539       REAL      SSUM
    540 
    541       DATA first/.true./
    542 
    543       !write(*,*) 'vly 578: entree, iq=',iq
    544 
    545       IF(first) THEN
    546          PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
    547          first=.false.
    548          do i=2,iip1
    549             coslon(i)=cos(rlonv(i))
    550             sinlon(i)=sin(rlonv(i))
    551             coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
    552             sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
    553          ENDDO
    554          coslon(1)=coslon(iip1)
    555          coslondlon(1)=coslondlon(iip1)
    556          sinlon(1)=sinlon(iip1)
    557          sinlondlon(1)=sinlondlon(iip1)
    558          airej2 = SSUM( iim, aire(iip2), 1 )
    559          airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
    560       ENDIF
    561 
    562 c
    563 cPRINT*,'CALCUL EN LATITUDE'
    564 
    565       DO l = 1, llm
    566 c
    567 c   --------------------------------
    568 c      CALCUL EN LATITUDE
    569 c   --------------------------------
    570 
    571 c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
    572 c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
    573 c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
    574 
    575       DO i = 1, iim
    576       airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
    577       airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    578       ENDDO
    579       qpns   = SSUM( iim,  airescb ,1 ) / airej2
    580       qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
    581 
    582 c   calcul des pentes aux points v
    583 
    584       DO ij=1,ip1jm
    585          dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    586          adyqv(ij)=abs(dyqv(ij))
    587       ENDDO
    588 
    589 c   calcul des pentes aux points scalaires
    590 
    591       DO ij=iip2,ip1jm
    592          dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
    593          dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
    594          dyqmax(ij)=pente_max*dyqmax(ij)
    595       ENDDO
    596 
    597 c   calcul des pentes aux poles
    598 
    599       DO ij=1,iip1
    600          dyq(ij,l)=qpns-q(ij+iip1,l,iq)
    601          dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    602       ENDDO
    603 
    604 c   filtrage de la derivee
    605       dyn1=0.
    606       dys1=0.
    607       dyn2=0.
    608       dys2=0.
    609       DO ij=1,iim
    610          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
    611          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
    612          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
    613          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
    614       ENDDO
    615       DO ij=1,iip1
    616          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
    617          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
    618       ENDDO
    619 
    620 c   calcul des pentes limites aux poles
    621 
    622       goto 8888
    623       fn=1.
    624       fs=1.
    625       DO ij=1,iim
    626          IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
    627             fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
    628          ENDIF
    629       IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
    630          fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
    631          ENDIF
    632       ENDDO
    633       DO ij=1,iip1
    634          dyq(ij,l)=fn*dyq(ij,l)
    635          dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
    636       ENDDO
    637 8888    continue
    638       DO ij=1,iip1
    639          dyq(ij,l)=0.
    640          dyq(ip1jm+ij,l)=0.
    641       ENDDO
    642 
    643 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    644 C  En memoire de dIFferents tests sur la
    645 C  limitation des pentes aux poles.
    646 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    647 C     PRINT*,dyq(1)
    648 C     PRINT*,dyqv(iip1+1)
    649 C     appn=abs(dyq(1)/dyqv(iip1+1))
    650 C     PRINT*,dyq(ip1jm+1)
    651 C     PRINT*,dyqv(ip1jm-iip1+1)
    652 C     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
    653 C     DO ij=2,iim
    654 C        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
    655 C        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
    656 C     ENDDO
    657 C     appn=min(pente_max/appn,1.)
    658 C     apps=min(pente_max/apps,1.)
    659 C
    660 C
    661 C   cas ou on a un extremum au pole
    662 C
    663 C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    664 C    &   appn=0.
    665 C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    666 C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    667 C    &   apps=0.
    668 C
    669 C   limitation des pentes aux poles
    670 C     DO ij=1,iip1
    671 C        dyq(ij)=appn*dyq(ij)
    672 C        dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
    673 C     ENDDO
    674 C
    675 C   test
    676 C      DO ij=1,iip1
    677 C         dyq(iip1+ij)=0.
    678 C         dyq(ip1jm+ij-iip1)=0.
    679 C      ENDDO
    680 C      DO ij=1,ip1jmp1
    681 C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
    682 C      ENDDO
    683 C
    684 C changement 10 07 96
    685 C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    686 C    &   THEN
    687 C        DO ij=1,iip1
    688 C           dyqmax(ij)=0.
    689 C        ENDDO
    690 C     ELSE
    691 C        DO ij=1,iip1
    692 C           dyqmax(ij)=pente_max*abs(dyqv(ij))
    693 C        ENDDO
    694 C     ENDIF
    695 C
    696 C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    697 C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    698 C    &THEN
    699 C        DO ij=ip1jm+1,ip1jmp1
    700 C           dyqmax(ij)=0.
    701 C        ENDDO
    702 C     ELSE
    703 C        DO ij=ip1jm+1,ip1jmp1
    704 C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
    705 C        ENDDO
    706 C     ENDIF
    707 C   fin changement 10 07 96
    708 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    709 
    710 c   calcul des pentes limitees
    711 
    712       DO ij=iip2,ip1jm
    713          IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
    714             dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
    715          ELSE
    716             dyq(ij,l)=0.
    717          ENDIF
    718       ENDDO
    719 
    720       ENDDO
    721 
    722       !write(*,*) 'vly 756'
    723       DO l=1,llm
    724        DO ij=1,ip1jm
    725           IF(masse_adv_v(ij,l).gt.0) THEN
    726               qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)*
    727      ,                   0.5*(1.-masse_adv_v(ij,l)
    728      ,                   /masse(ij+iip1,l,iq))
    729           ELSE
    730               qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)*
    731      ,                   0.5*(1.+masse_adv_v(ij,l)
    732      ,                   /masse(ij,l,iq))
    733           ENDIF
    734           qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
    735        ENDDO
    736       ENDDO
    737 
    738 ! CRisi: appel récursif de l'advection sur les fils.
    739 ! Il faut faire ça avant d'avoir mis à jour q et masse
    740       !write(*,*) 'vly 689: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
    741    
    742       do ifils=1,tracers(iq)%nqDescen
    743         iq2=tracers(iq)%iqDescen(ifils)
    744         DO l=1,llm
    745           DO ij=1,ip1jmp1
    746             ! attention, chaque fils doit avoir son masseq, sinon, le 1er
    747             ! fils ecrase le masseq de ses freres.
    748             !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    749             !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
    750             !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    751             masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    752             if (q(ij,l,iq).gt.min_qParent) then
    753               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    754             else
    755               Ratio(ij,l,iq2)=min_ratio
    756             endif
    757           enddo   
    758         enddo
    759       enddo
    760 
    761       do ifils=1,tracers(iq)%nqDescen
    762         iq2=tracers(iq)%iqDescen(ifils)
    763         call vly(Ratio,pente_max,masseq,qbyv,iq2)
    764       enddo
    765 
    766       DO l=1,llm
    767          DO ij=iip2,ip1jm
    768             newmasse=masse(ij,l,iq)
    769      &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    770             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
    771      &         -qbyv(ij-iip1,l))/newmasse
    772             masse(ij,l,iq)=newmasse
    773          ENDDO
    774 c.-. ancienne version
    775 c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
    776 c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
    777 
    778          convpn=SSUM(iim,qbyv(1,l),1)
    779          convmpn=ssum(iim,masse_adv_v(1,l),1)
    780          massepn=ssum(iim,masse(1,l,iq),1)
    781          qpn=0.
    782          do ij=1,iim
    783             qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
    784          enddo
    785          qpn=(qpn+convpn)/(massepn+convmpn)
    786          do ij=1,iip1
    787             q(ij,l,iq)=qpn
    788          enddo
    789 
    790 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
    791 c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
    792 
    793          convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    794          convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    795          masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
    796          qps=0.
    797          do ij = ip1jm+1,ip1jmp1-1
    798             qps=qps+masse(ij,l,iq)*q(ij,l,iq)
    799          enddo
    800          qps=(qps+convps)/(masseps+convmps)
    801          do ij=ip1jm+1,ip1jmp1
    802             q(ij,l,iq)=qps
    803          enddo
    804 
    805 c.-. fin ancienne version
    806 
    807 c._. nouvelle version
    808 c        convpn=SSUM(iim,qbyv(1,l),1)
    809 c        convmpn=ssum(iim,masse_adv_v(1,l),1)
    810 c        oldmasse=ssum(iim,masse(1,l),1)
    811 c        newmasse=oldmasse+convmpn
    812 c        newq=(q(1,l)*oldmasse+convpn)/newmasse
    813 c        newmasse=newmasse/apoln
    814 c        DO ij = 1,iip1
    815 c           q(ij,l)=newq
    816 c           masse(ij,l,iq)=newmasse*aire(ij)
    817 c        ENDDO
    818 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    819 c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    820 c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
    821 c        newmasse=oldmasse+convmps
    822 c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
    823 c        newmasse=newmasse/apols
    824 c        DO ij = ip1jm+1,ip1jmp1
    825 c           q(ij,l)=newq
    826 c           masse(ij,l,iq)=newmasse*aire(ij)
    827 c        ENDDO
    828 c._. fin nouvelle version
    829       ENDDO
    830  
    831 ! retablir les fils en rapport de melange par rapport a l'air:
    832       do ifils=1,tracers(iq)%nqDescen
    833         iq2=tracers(iq)%iqDescen(ifils)
    834         DO l=1,llm
    835           DO ij=1,ip1jmp1
    836             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    837           enddo
    838         enddo
    839       enddo
    840 
    841       !write(*,*) 'vly 853: sortie'
    842 
    843       RETURN
    844       END
    845       RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
    846       USE infotrac, ONLY : nqtot,tracers, ! CRisi
    847      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    848 c
    849 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    850 c
    851 c    ********************************************************************
    852 c     Shema  d'advection " pseudo amont " .
    853 c    ********************************************************************
    854 c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    855 c     dq               sont des arguments de sortie pour le s-pg ....
    856 c
    857 c
    858 c   --------------------------------------------------------------------
    859       IMPLICIT NONE
    860 c
    861       include "dimensions.h"
    862       include "paramet.h"
    863 c
    864 c
    865 c   Arguments:
    866 c   ----------
    867       REAL masse(ip1jmp1,llm,nqtot),pente_max
    868       REAL q(ip1jmp1,llm,nqtot)
    869       REAL w(ip1jmp1,llm+1)
    870       INTEGER iq
    871 c
    872 c      Local
    873 c   ---------
    874 c
    875       INTEGER ij,l
    876 c
    877       REAL wq(ip1jmp1,llm+1),newmasse
    878 
    879       REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
    880       REAL sigw
    881 
    882       REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    883       INTEGER ifils,iq2 ! CRisi
    884 
    885       LOGICAL testcpu
    886       SAVE testcpu
    887 
    888 #ifdef BIDON
    889       REAL temps0,temps1,second
    890       SAVE temps0,temps1
    891 
    892       DATA testcpu/.false./
    893       DATA temps0,temps1/0.,0./
    894 #endif
    895 
    896 c    On oriente tout dans le sens de la pression c'est a dire dans le
    897 c    sens de W
    898 
    899       !write(*,*) 'vlz 923: entree'
    900 
    901 #ifdef BIDON
    902       IF(testcpu) THEN
    903          temps0=second(0.)
    904       ENDIF
    905 #endif
    906       DO l=2,llm
    907          DO ij=1,ip1jmp1
    908             dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
    909             adzqw(ij,l)=abs(dzqw(ij,l))
    910          ENDDO
    911       ENDDO
    912 
    913       DO l=2,llm-1
    914          DO ij=1,ip1jmp1
    915 #ifdef CRAY
    916             dzq(ij,l)=0.5*
    917      ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
    918 #else
    919             IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
    920                 dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
    921             ELSE
    922                 dzq(ij,l)=0.
    923             ENDIF
    924 #endif
    925             dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
    926             dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
    927          ENDDO
    928       ENDDO
    929 
    930       !write(*,*) 'vlz 954'
    931       DO ij=1,ip1jmp1
    932          dzq(ij,1)=0.
    933          dzq(ij,llm)=0.
    934       ENDDO
    935 
    936 #ifdef BIDON
    937       IF(testcpu) THEN
    938          temps1=temps1+second(0.)-temps0
    939       ENDIF
    940 #endif
    941 c ---------------------------------------------------------------
    942 c   .... calcul des termes d'advection verticale  .......
    943 c ---------------------------------------------------------------
    944 
    945 c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
    946 
    947        !write(*,*) 'vlz 969'
    948        DO l = 1,llm-1
    949          do  ij = 1,ip1jmp1
    950           IF(w(ij,l+1).gt.0.) THEN
    951              sigw=w(ij,l+1)/masse(ij,l+1,iq)
    952              wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq)
    953      &           +0.5*(1.-sigw)*dzq(ij,l+1))
    954           ELSE
    955              sigw=w(ij,l+1)/masse(ij,l,iq)
    956              wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l))
    957           ENDIF
    958          ENDDO
    959        ENDDO
    960 
    961        DO ij=1,ip1jmp1
    962           wq(ij,llm+1)=0.
    963           wq(ij,1)=0.
    964        ENDDO
    965 
    966 ! CRisi: appel récursif de l'advection sur les fils.
    967 ! Il faut faire ça avant d'avoir mis à jour q et masse
    968       !write(*,*) 'vlsplt 942: iq,nqChildren(iq)=',iq,nqChildren(iq)
    969       do ifils=1,tracers(iq)%nqDescen
    970         iq2=tracers(iq)%iqDescen(ifils)
    971         DO l=1,llm
    972           DO ij=1,ip1jmp1
    973             !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    974             !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)       
    975             !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    976             masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    977             if (q(ij,l,iq).gt.min_qParent) then
    978               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    979             else
    980               Ratio(ij,l,iq2)=min_ratio
    981             endif     
    982           enddo   
    983         enddo
    984       enddo
    985        
    986       do ifils=1,tracers(iq)%nqChildren
    987         iq2=tracers(iq)%iqDescen(ifils)
    988         call vlz(Ratio,pente_max,masseq,wq,iq2)
    989       enddo
    990 ! end CRisi 
    991 
    992       DO l=1,llm
    993          DO ij=1,ip1jmp1
    994             newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l)
    995             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l))
    996      &         /newmasse
    997             masse(ij,l,iq)=newmasse
    998          ENDDO
    999       ENDDO
    1000 
    1001 ! retablir les fils en rapport de melange par rapport a l'air:
    1002       do ifils=1,tracers(iq)%nqDescen
    1003         iq2=tracers(iq)%iqDescen(ifils)
    1004         DO l=1,llm
    1005           DO ij=1,ip1jmp1
    1006             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    1007           enddo
    1008         enddo
    1009       enddo
    1010       !write(*,*) 'vlsplt 1032'
    1011 
    1012       RETURN
    1013       END
    1014 c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
    1015 c
    1016 c#include "dimensions.h"
    1017 c#include "paramet.h"
    1018 
    1019 c      CHARACTER*(*) comment
    1020 c      real qmin,qmax
    1021 c      real zq(ip1jmp1,llm)
    1022 
    1023 c      INTEGER jadrs(ip1jmp1), jbad, k, i
    1024 
    1025 
    1026 c      DO k = 1, llm
    1027 c         jbad = 0
    1028 c         DO i = 1, ip1jmp1
    1029 c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
    1030 c            jbad = jbad + 1
    1031 c            jadrs(jbad) = i
    1032 c         ENDIF
    1033 c         ENDDO
    1034 c         IF (jbad.GT.0) THEN
    1035 c         PRINT*, comment
    1036 c         DO i = 1, jbad
    1037 cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
    1038 c         ENDDO
    1039 c         ENDIF
    1040 c      ENDDO
    1041 
    1042 c      return
    1043 c      end
    1044       subroutine minmaxq(zq,qmin,qmax,comment)
     1008    enddo
     1009  enddo
     1010  ! !write(*,*) 'vlsplt 1032'
     1011
     1012  RETURN
     1013END SUBROUTINE vlz
     1014 ! SUBROUTINE minmaxq(zq,qmin,qmax,comment)
     1015!
     1016!#include "dimensions.h"
     1017!#include "paramet.h"
     1018
     1019!  CHARACTER*(*) comment
     1020!  real qmin,qmax
     1021!  real zq(ip1jmp1,llm)
     1022
     1023!  INTEGER jadrs(ip1jmp1), jbad, k, i
     1024
     1025
     1026!  DO k = 1, llm
     1027!     jbad = 0
     1028!     DO i = 1, ip1jmp1
     1029!     IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
     1030!        jbad = jbad + 1
     1031!        jadrs(jbad) = i
     1032!     ENDIF
     1033!     ENDDO
     1034!     IF (jbad.GT.0) THEN
     1035!     PRINT*, comment
     1036!     DO i = 1, jbad
     1037!c            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
     1038!     ENDDO
     1039!     ENDIF
     1040!  ENDDO
     1041
     1042!  return
     1043!  end
     1044subroutine minmaxq(zq,qmin,qmax,comment)
    10451045
    10461046#include "dimensions.h"
    10471047#include "paramet.h"
    10481048
    1049       character*20 comment
    1050       real qmin,qmax
    1051       real zq(ip1jmp1,llm)
    1052       real zzq(iip1,jjp1,llm)
     1049  character(len=20) :: comment
     1050  real :: qmin,qmax
     1051  real :: zq(ip1jmp1,llm)
     1052  real :: zzq(iip1,jjp1,llm)
    10531053
    10541054#ifdef isminmax
    1055       integer imin,jmin,lmin,ijlmin
    1056       integer imax,jmax,lmax,ijlmax
    1057 
    1058       integer ismin,ismax
    1059 
    1060       call scopy (ip1jmp1*llm,zq,1,zzq,1)
    1061 
    1062       ijlmin=ismin(ijp1llm,zq,1)
    1063       lmin=(ijlmin-1)/ip1jmp1+1
    1064       ijlmin=ijlmin-(lmin-1.)*ip1jmp1
    1065       jmin=(ijlmin-1)/iip1+1
    1066       imin=ijlmin-(jmin-1.)*iip1
    1067       zqmin=zq(ijlmin,lmin)
    1068 
    1069       ijlmax=ismax(ijp1llm,zq,1)
    1070       lmax=(ijlmax-1)/ip1jmp1+1
    1071       ijlmax=ijlmax-(lmax-1.)*ip1jmp1
    1072       jmax=(ijlmax-1)/iip1+1
    1073       imax=ijlmax-(jmax-1.)*iip1
    1074       zqmax=zq(ijlmax,lmax)
    1075 
    1076        if(zqmin.lt.qmin)
    1077 c    s     write(*,9999) comment,
    1078      s     write(*,*) comment,
    1079      s     imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)
    1080        if(zqmax.gt.qmax)
    1081 c    s     write(*,9999) comment,
    1082      s     write(*,*) comment,
    1083      s     imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)
     1055  integer :: imin,jmin,lmin,ijlmin
     1056  integer :: imax,jmax,lmax,ijlmax
     1057
     1058  integer :: ismin,ismax
     1059
     1060  call scopy (ip1jmp1*llm,zq,1,zzq,1)
     1061
     1062  ijlmin=ismin(ijp1llm,zq,1)
     1063  lmin=(ijlmin-1)/ip1jmp1+1
     1064  ijlmin=ijlmin-(lmin-1.)*ip1jmp1
     1065  jmin=(ijlmin-1)/iip1+1
     1066  imin=ijlmin-(jmin-1.)*iip1
     1067  zqmin=zq(ijlmin,lmin)
     1068
     1069  ijlmax=ismax(ijp1llm,zq,1)
     1070  lmax=(ijlmax-1)/ip1jmp1+1
     1071  ijlmax=ijlmax-(lmax-1.)*ip1jmp1
     1072  jmax=(ijlmax-1)/iip1+1
     1073  imax=ijlmax-(jmax-1.)*iip1
     1074  zqmax=zq(ijlmax,lmax)
     1075
     1076   if(zqmin.lt.qmin) &
     1077  ! s     write(*,9999) comment,
     1078         write(*,*) comment, &
     1079         imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)
     1080   if(zqmax.gt.qmax) &
     1081  ! s     write(*,9999) comment,
     1082         write(*,*) comment, &
     1083         imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)
    10841084
    10851085#endif
    1086       return
    1087 c9999  format(a20,'  q(',i3,',',i2,',',i2,')=',e12.5,e12.5)
    1088       end
    1089 
    1090 
    1091 
     1086  return
     1087  !9999  format(a20,'  q(',i3,',',i2,',',i2,')=',e12.5,e12.5)
     1088end subroutine minmaxq
     1089
     1090
     1091
  • LMDZ6/trunk/libf/dyn3dmem/vlsplt_loc.F90

    r5247 r5248  
    22! $Id$
    33!
    4       RECURSIVE SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x,iq)
    5 
    6 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    7 c
    8 c    ********************************************************************
    9 c    Shema  d'advection " pseudo amont " .
    10 c    ********************************************************************
    11 c    nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    12 c
    13 c
    14 c   --------------------------------------------------------------------
    15       USE parallel_lmdz
    16       USE infotrac, ONLY : nqtot,tracers, ! CRisi                 &
    17      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    18       IMPLICIT NONE
    19 c
    20       include "dimensions.h"
    21       include "paramet.h"
    22       include "iniprint.h"
    23 c
    24 c
    25 c   Arguments:
    26 c   ----------
    27       REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
    28       REAL u_m( ijb_u:ije_u,llm),pbarv( iip1,jjb_v:jje_v,llm)
    29       REAL q(ijb_u:ije_u,llm,nqtot) ! CRisi: ajout dimension nqtot
    30       REAL w(ijb_u:ije_u,llm)
    31       INTEGER iq ! CRisi
    32 c
    33 c      Local
    34 c   ---------
    35 c
    36       INTEGER ij,l,j,i,iju,ijq,indu(ijnb_u),niju
    37       INTEGER n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
    38 c
    39       REAL new_m,zu_m,zdum(ijb_u:ije_u,llm)
    40       REAL sigu(ijb_u:ije_u),dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
    41       REAL zz(ijb_u:ije_u)
    42       REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
    43       REAL u_mq(ijb_u:ije_u,llm)
    44 
    45       REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
    46       INTEGER ifils,iq2 ! CRisi
    47 
    48       Logical extremum
    49 
    50       REAL      SSUM
    51       EXTERNAL  SSUM
    52 
    53       REAL z1,z2,z3
    54 
    55       INTEGER ijb,ije,ijb_x,ije_x
    56      
    57       !write(*,*) 'vlsplt 58: entree dans vlx_loc, iq,ijb_x=',
    58 !    &   iq,ijb_x
    59 c   calcul de la pente a droite et a gauche de la maille
    60 
    61       ijb=ijb_x
    62       ije=ije_x
    63        
    64       if (pole_nord.and.ijb==1) ijb=ijb+iip1
    65       if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
    66          
    67       IF (pente_max.gt.-1.e-5) THEN
    68 c      IF (pente_max.gt.10) THEN
    69 
    70 c   calcul des pentes avec limitation, Van Leer scheme I:
    71 c   -----------------------------------------------------
    72       ! on a besoin de q entre ijb et ije
    73 c   calcul de la pente aux points u
    74 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
    75          DO l = 1, llm
    76            
    77             DO ij=ijb,ije-1
    78                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    79 c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
    80 c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
    81             ENDDO
    82             DO ij=ijb+iip1-1,ije,iip1
    83                dxqu(ij)=dxqu(ij-iim)
    84 c              sigu(ij)=sigu(ij-iim)
    85             ENDDO
    86 
    87             DO ij=ijb,ije
    88                adxqu(ij)=abs(dxqu(ij))
    89             ENDDO
    90 
    91 c   calcul de la pente maximum dans la maille en valeur absolue
    92 
    93             DO ij=ijb+1,ije
    94                dxqmax(ij,l)=pente_max*
    95      ,      min(adxqu(ij-1),adxqu(ij))
    96 c limitation subtile
    97 c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
    98          
    99 
    100             ENDDO
    101 
    102             DO ij=ijb+iip1-1,ije,iip1
    103                dxqmax(ij-iim,l)=dxqmax(ij,l)
    104             ENDDO
    105 
    106             DO ij=ijb+1,ije
     4RECURSIVE SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x,iq)
     5
     6  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     7  !
     8  !    ********************************************************************
     9  ! Shema  d'advection " pseudo amont " .
     10  !    ********************************************************************
     11  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     12  !
     13  !
     14  !   --------------------------------------------------------------------
     15  USE parallel_lmdz
     16  USE infotrac, ONLY : nqtot,tracers, & ! CRisi                 &
     17        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     18  IMPLICIT NONE
     19  !
     20  include "dimensions.h"
     21  include "paramet.h"
     22  include "iniprint.h"
     23  !
     24  !
     25  !   Arguments:
     26  !   ----------
     27  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
     28  REAL :: u_m( ijb_u:ije_u,llm),pbarv( iip1,jjb_v:jje_v,llm)
     29  REAL :: q(ijb_u:ije_u,llm,nqtot) ! CRisi: ajout dimension nqtot
     30  REAL :: w(ijb_u:ije_u,llm)
     31  INTEGER :: iq ! CRisi
     32  !
     33  !  Local
     34  !   ---------
     35  !
     36  INTEGER :: ij,l,j,i,iju,ijq,indu(ijnb_u),niju
     37  INTEGER :: n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
     38  !
     39  REAL :: new_m,zu_m,zdum(ijb_u:ije_u,llm)
     40  REAL :: sigu(ijb_u:ije_u),dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
     41  REAL :: zz(ijb_u:ije_u)
     42  REAL :: adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
     43  REAL :: u_mq(ijb_u:ije_u,llm)
     44
     45  REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
     46  INTEGER :: ifils,iq2 ! CRisi
     47
     48  Logical :: extremum
     49
     50  REAL :: SSUM
     51  EXTERNAL  SSUM
     52
     53  REAL :: z1,z2,z3
     54
     55  INTEGER :: ijb,ije,ijb_x,ije_x
     56
     57  ! !write(*,*) 'vlsplt 58: entree dans vlx_loc, iq,ijb_x=',
     58  ! &   iq,ijb_x
     59  !   calcul de la pente a droite et a gauche de la maille
     60
     61  ijb=ijb_x
     62  ije=ije_x
     63
     64  if (pole_nord.and.ijb==1) ijb=ijb+iip1
     65  if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
     66
     67  IF (pente_max.gt.-1.e-5) THEN
     68    ! IF (pente_max.gt.10) THEN
     69
     70  !   calcul des pentes avec limitation, Van Leer scheme I:
     71  !   -----------------------------------------------------
     72  ! ! on a besoin de q entre ijb et ije
     73  !   calcul de la pente aux points u
     74!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     75     DO l = 1, llm
     76
     77        DO ij=ijb,ije-1
     78           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
     79           ! IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
     80           ! sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
     81        ENDDO
     82        DO ij=ijb+iip1-1,ije,iip1
     83           dxqu(ij)=dxqu(ij-iim)
     84           ! sigu(ij)=sigu(ij-iim)
     85        ENDDO
     86
     87        DO ij=ijb,ije
     88           adxqu(ij)=abs(dxqu(ij))
     89        ENDDO
     90
     91  !   calcul de la pente maximum dans la maille en valeur absolue
     92
     93        DO ij=ijb+1,ije
     94           dxqmax(ij,l)=pente_max* &
     95                 min(adxqu(ij-1),adxqu(ij))
     96  ! limitation subtile
     97  !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
     98
     99
     100        ENDDO
     101
     102        DO ij=ijb+iip1-1,ije,iip1
     103           dxqmax(ij-iim,l)=dxqmax(ij,l)
     104        ENDDO
     105
     106        DO ij=ijb+1,ije
    107107#ifdef CRAY
    108                dxq(ij,l)=
    109      ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
     108           dxq(ij,l)= &
     109                 cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
    110110#else
    111                IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
    112                   dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
    113                ELSE
    114 c   extremum local
    115                   dxq(ij,l)=0.
    116                ENDIF
     111           IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
     112              dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
     113           ELSE
     114  !   extremum local
     115              dxq(ij,l)=0.
     116           ENDIF
    117117#endif
    118                dxq(ij,l)=0.5*dxq(ij,l)
    119                dxq(ij,l)=
    120      ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
    121             ENDDO
    122 
    123          ENDDO ! l=1,llm
    124 c$OMP END DO NOWAIT
    125 c       print*,'Ok calcul des pentes'
    126 
    127       ELSE ! (pente_max.lt.-1.e-5)
    128 
    129 c   Pentes produits:
    130 c   ----------------
    131 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    132          DO l = 1, llm
    133             DO ij=ijb,ije-1
    134                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    135             ENDDO
    136             DO ij=ijb+iip1-1,ije,iip1
    137                dxqu(ij)=dxqu(ij-iim)
    138             ENDDO
    139 
    140             DO ij=ijb+1,ije
    141                zz(ij)=dxqu(ij-1)*dxqu(ij)
    142                zz(ij)=zz(ij)+zz(ij)
    143                IF(zz(ij).gt.0) THEN
    144                   dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
    145                ELSE
    146 c   extremum local
    147                   dxq(ij,l)=0.
    148                ENDIF
    149             ENDDO
    150 
    151          ENDDO
    152 c$OMP END DO NOWAIT
    153       ENDIF ! (pente_max.lt.-1.e-5)
    154 
    155       !write(*,*) 'vlx 156: iq,ijb_x=',iq,ijb_x
    156 
    157 c   bouclage de la pente en iip1:
    158 c   -----------------------------
    159 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    160       DO l=1,llm
    161          DO ij=ijb+iip1-1,ije,iip1
    162             dxq(ij-iim,l)=dxq(ij,l)
    163          ENDDO
    164          DO ij=ijb,ije
    165             iadvplus(ij,l)=0
    166          ENDDO
    167 
    168       ENDDO
    169 c$OMP END DO NOWAIT
    170 c        print*,'Bouclage en iip1'
    171 
    172 c   calcul des flux a gauche et a droite
     118           dxq(ij,l)=0.5*dxq(ij,l)
     119           dxq(ij,l)= &
     120                 sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
     121        ENDDO
     122
     123     ENDDO ! l=1,llm
     124!$OMP END DO NOWAIT
     125  ! print*,'Ok calcul des pentes'
     126
     127  ELSE ! (pente_max.lt.-1.e-5)
     128
     129  !   Pentes produits:
     130  !   ----------------
     131!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     132     DO l = 1, llm
     133        DO ij=ijb,ije-1
     134           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
     135        ENDDO
     136        DO ij=ijb+iip1-1,ije,iip1
     137           dxqu(ij)=dxqu(ij-iim)
     138        ENDDO
     139
     140        DO ij=ijb+1,ije
     141           zz(ij)=dxqu(ij-1)*dxqu(ij)
     142           zz(ij)=zz(ij)+zz(ij)
     143           IF(zz(ij).gt.0) THEN
     144              dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
     145           ELSE
     146  !   extremum local
     147              dxq(ij,l)=0.
     148           ENDIF
     149        ENDDO
     150
     151     ENDDO
     152!$OMP END DO NOWAIT
     153  ENDIF ! (pente_max.lt.-1.e-5)
     154
     155  ! !write(*,*) 'vlx 156: iq,ijb_x=',iq,ijb_x
     156
     157  !   bouclage de la pente en iip1:
     158  !   -----------------------------
     159!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     160  DO l=1,llm
     161     DO ij=ijb+iip1-1,ije,iip1
     162        dxq(ij-iim,l)=dxq(ij,l)
     163     ENDDO
     164     DO ij=ijb,ije
     165        iadvplus(ij,l)=0
     166     ENDDO
     167
     168  ENDDO
     169!$OMP END DO NOWAIT
     170   ! print*,'Bouclage en iip1'
     171
     172  !   calcul des flux a gauche et a droite
    173173
    174174#ifdef CRAY
    175 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    176       DO l=1,llm
    177        DO ij=ijb,ije-1
    178           zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
    179      ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
    180      ,                     u_m(ij,l,iq))
    181           zdum(ij,l)=0.5*zdum(ij,l)
    182           u_mq(ij,l)=cvmgp(
    183      ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
    184      ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
    185      ,                u_m(ij,l))
    186           u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
    187        ENDDO
    188       ENDDO
    189 c$OMP END DO NOWAIT
     175!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     176  DO l=1,llm
     177   DO ij=ijb,ije-1
     178      zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq), &
     179            1.+u_m(ij,l)/masse(ij+1,l,iq), &
     180            u_m(ij,l,iq))
     181      zdum(ij,l)=0.5*zdum(ij,l)
     182      u_mq(ij,l)=cvmgp( &
     183            q(ij,l,iq)+zdum(ij,l)*dxq(ij,l), &
     184            q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l), &
     185            u_m(ij,l))
     186      u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
     187   ENDDO
     188  ENDDO
     189!$OMP END DO NOWAIT
    190190#else
    191 c   on cumule le flux correspondant a toutes les mailles dont la masse
    192 c   au travers de la paroi pENDant le pas de temps.
    193 c       print*,'Cumule ....'
    194 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    195         ! on a besoin de masse entre ijb et ije
    196       DO l=1,llm
    197        DO ij=ijb,ije-1
    198 c       print*,'masse(',ij,')=',masse(ij,l,iq)
    199           IF (u_m(ij,l).gt.0.) THEN
    200              zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
    201              u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)
    202      :           +0.5*zdum(ij,l)*dxq(ij,l))
    203           ELSE
    204              zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
    205              u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)
    206      :           -0.5*zdum(ij,l)*dxq(ij+1,l))
    207           ENDIF
    208        ENDDO
    209       ENDDO
    210 c$OMP END DO NOWAIT
     191  !   on cumule le flux correspondant a toutes les mailles dont la masse
     192  !   au travers de la paroi pENDant le pas de temps.
     193  ! print*,'Cumule ....'
     194!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     195    ! ! on a besoin de masse entre ijb et ije
     196  DO l=1,llm
     197   DO ij=ijb,ije-1
     198  ! print*,'masse(',ij,')=',masse(ij,l,iq)
     199      IF (u_m(ij,l).gt.0.) THEN
     200         zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
     201         u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq) &
     202               +0.5*zdum(ij,l)*dxq(ij,l))
     203      ELSE
     204         zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
     205         u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq) &
     206               -0.5*zdum(ij,l)*dxq(ij+1,l))
     207      ENDIF
     208   ENDDO
     209  ENDDO
     210!$OMP END DO NOWAIT
    211211#endif
    212212
    213 c       go to 9999
    214 c   detection des points ou on advecte plus que la masse de la
    215 c   maille
    216 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    217       DO l=1,llm
    218          DO ij=ijb,ije-1
    219             IF(zdum(ij,l).lt.0) THEN
    220                iadvplus(ij,l)=1
    221                u_mq(ij,l)=0.
    222             ENDIF
    223          ENDDO
    224       ENDDO
    225 c$OMP END DO NOWAIT
    226 c       print*,'Ok test 1'
    227 
    228 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    229       DO l=1,llm
    230        DO ij=ijb+iip1-1,ije,iip1
    231           iadvplus(ij,l)=iadvplus(ij-iim,l)
    232        ENDDO
    233       ENDDO
    234 c$OMP END DO NOWAIT
    235 c        print*,'Ok test 2'
    236        
    237 
    238 c   traitement special pour le cas ou on advecte en longitude plus que le
    239 c   contenu de la maille.
    240 c   cette partie est mal vectorisee.
    241 
    242 c  calcul du nombre de maille sur lequel on advecte plus que la maille.
    243 
    244       n0=0
    245 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    246       DO l=1,llm
    247          nl(l)=0
    248          DO ij=ijb,ije
    249             nl(l)=nl(l)+iadvplus(ij,l)
    250          ENDDO
    251          n0=n0+nl(l)
    252       ENDDO
    253 c$OMP END DO NOWAIT
    254 cym      IF(n0.gt.1) THEN
    255 cym      IF(n0.gt.0) THEN
    256 
    257 c      PRINT*,'Nombre de points pour lesquels on advect plus que le'
    258 c     &       ,'contenu de la maille : ',n0
    259 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    260 
    261 
    262          DO l=1,llm
    263             IF(nl(l).gt.0) THEN
    264                iju=0
    265 c   indicage des mailles concernees par le traitement special
    266                DO ij=ijb,ije
    267                   IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
    268                      iju=iju+1
    269                      indu(iju)=ij
    270                   ENDIF
    271                ENDDO
    272                niju=iju
    273                !PRINT*,'vlx 278, niju,nl',niju,nl(l)
    274 
    275 c  traitement des mailles
    276                DO iju=1,niju
    277                   ij=indu(iju)
    278                   j=(ij-1)/iip1+1
    279                   zu_m=u_m(ij,l)
    280                   u_mq(ij,l)=0.
    281                   IF(zu_m.gt.0.) THEN
    282                      ijq=ij
    283                      i=ijq-(j-1)*iip1
    284 c   accumulation pour les mailles completements advectees
    285                      do while(zu_m.gt.masse(ijq,l,iq))
    286                         u_mq(ij,l)=u_mq(ij,l)
    287      &                          +q(ijq,l,iq)*masse(ijq,l,iq)
    288                         zu_m=zu_m-masse(ijq,l,iq)
    289                         i=mod(i-2+iim,iim)+1
    290                         ijq=(j-1)*iip1+i
    291                      ENDDO
    292 c   ajout de la maille non completement advectee
    293                      u_mq(ij,l)=u_mq(ij,l)+zu_m*
    294      &               (q(ijq,l,iq)+0.5*
    295      &               (1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    296                   ELSE
    297                      ijq=ij+1
    298                      i=ijq-(j-1)*iip1
    299 c   accumulation pour les mailles completements advectees
    300                      do while(-zu_m.gt.masse(ijq,l,iq))
    301                         u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
    302      &                           *masse(ijq,l,iq)
    303                         zu_m=zu_m+masse(ijq,l,iq)
    304                         i=mod(i,iim)+1
    305                         ijq=(j-1)*iip1+i
    306                      ENDDO
    307 c   ajout de la maille non completement advectee
    308                      u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
    309      &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    310                   ENDIF
    311                ENDDO
    312             ENDIF
    313          ENDDO
    314 c$OMP END DO NOWAIT
    315 cym      ENDIF  ! n0.gt.0
    316 9999    continue
    317 
    318 c   bouclage en latitude
    319 c       print*,'Avant bouclage en latitude'
    320 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    321       DO l=1,llm
    322         DO ij=ijb+iip1-1,ije,iip1
    323            u_mq(ij,l)=u_mq(ij-iim,l)
    324         ENDDO
    325       ENDDO
    326 c$OMP END DO NOWAIT
    327 
    328 ! CRisi: appel récursif de l'advection sur les fils.
    329 ! Il faut faire ça avant d'avoir mis à jour q et masse
    330 
    331       do ifils=1,tracers(iq)%nqDescen
    332         ! attention: comme Ratio est utilisé comme q dans l'appel
    333         ! recursif, il doit contenir à lui seul tous les indices de tous
    334         ! les descendants!
    335         iq2=tracers(iq)%iqDescen(ifils)
    336 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    337         DO l=1,llm
    338           DO ij=ijb,ije
    339             ! On a besoin de q et masse seulement entre ijb et ije. On ne
    340             ! les calcule donc que de ijb à ije
    341             !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    342             masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    343             if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
    344               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    345             else
    346               Ratio(ij,l,iq2)=min_ratio
    347             endif
    348           enddo   
    349         enddo
    350 c$OMP END DO NOWAIT
    351       enddo !do ifils=1,tracers(iq)%nqDescen
    352       do ifils=1,tracers(iq)%nqChildren
    353         iq2=tracers(iq)%iqDescen(ifils)
    354         call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
     213  ! go to 9999
     214  !   detection des points ou on advecte plus que la masse de la
     215  !   maille
     216!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     217  DO l=1,llm
     218     DO ij=ijb,ije-1
     219        IF(zdum(ij,l).lt.0) THEN
     220           iadvplus(ij,l)=1
     221           u_mq(ij,l)=0.
     222        ENDIF
     223     ENDDO
     224  ENDDO
     225!$OMP END DO NOWAIT
     226  ! print*,'Ok test 1'
     227
     228!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     229  DO l=1,llm
     230   DO ij=ijb+iip1-1,ije,iip1
     231      iadvplus(ij,l)=iadvplus(ij-iim,l)
     232   ENDDO
     233  ENDDO
     234!$OMP END DO NOWAIT
     235   ! print*,'Ok test 2'
     236
     237
     238  !   traitement special pour le cas ou on advecte en longitude plus que le
     239  !   contenu de la maille.
     240  !   cette partie est mal vectorisee.
     241
     242  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
     243
     244  n0=0
     245!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     246  DO l=1,llm
     247     nl(l)=0
     248     DO ij=ijb,ije
     249        nl(l)=nl(l)+iadvplus(ij,l)
     250     ENDDO
     251     n0=n0+nl(l)
     252  ENDDO
     253!$OMP END DO NOWAIT
     254  !ym      IF(n0.gt.1) THEN
     255  !ym      IF(n0.gt.0) THEN
     256
     257   ! PRINT*,'Nombre de points pour lesquels on advect plus que le'
     258  ! &       ,'contenu de la maille : ',n0
     259!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     260
     261
     262     DO l=1,llm
     263        IF(nl(l).gt.0) THEN
     264           iju=0
     265  !   indicage des mailles concernees par le traitement special
     266           DO ij=ijb,ije
     267              IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
     268                 iju=iju+1
     269                 indu(iju)=ij
     270              ENDIF
     271           ENDDO
     272           niju=iju
     273           ! !PRINT*,'vlx 278, niju,nl',niju,nl(l)
     274
     275  !  traitement des mailles
     276           DO iju=1,niju
     277              ij=indu(iju)
     278              j=(ij-1)/iip1+1
     279              zu_m=u_m(ij,l)
     280              u_mq(ij,l)=0.
     281              IF(zu_m.gt.0.) THEN
     282                 ijq=ij
     283                 i=ijq-(j-1)*iip1
     284  !   accumulation pour les mailles completements advectees
     285                 do while(zu_m.gt.masse(ijq,l,iq))
     286                    u_mq(ij,l)=u_mq(ij,l) &
     287                          +q(ijq,l,iq)*masse(ijq,l,iq)
     288                    zu_m=zu_m-masse(ijq,l,iq)
     289                    i=mod(i-2+iim,iim)+1
     290                    ijq=(j-1)*iip1+i
     291                 ENDDO
     292  !   ajout de la maille non completement advectee
     293                 u_mq(ij,l)=u_mq(ij,l)+zu_m* &
     294                       (q(ijq,l,iq)+0.5* &
     295                       (1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
     296              ELSE
     297                 ijq=ij+1
     298                 i=ijq-(j-1)*iip1
     299  !   accumulation pour les mailles completements advectees
     300                 do while(-zu_m.gt.masse(ijq,l,iq))
     301                    u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) &
     302                          *masse(ijq,l,iq)
     303                    zu_m=zu_m+masse(ijq,l,iq)
     304                    i=mod(i,iim)+1
     305                    ijq=(j-1)*iip1+i
     306                 ENDDO
     307  !   ajout de la maille non completement advectee
     308                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- &
     309                       0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
     310              ENDIF
     311           ENDDO
     312        ENDIF
     313     ENDDO
     314!$OMP END DO NOWAIT
     315  !ym      ENDIF  ! n0.gt.0
     3169999   continue
     317
     318  !   bouclage en latitude
     319  ! print*,'Avant bouclage en latitude'
     320!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     321  DO l=1,llm
     322    DO ij=ijb+iip1-1,ije,iip1
     323       u_mq(ij,l)=u_mq(ij-iim,l)
     324    ENDDO
     325  ENDDO
     326!$OMP END DO NOWAIT
     327
     328  ! CRisi: appel récursif de l'advection sur les fils.
     329  ! Il faut faire ça avant d'avoir mis à jour q et masse
     330
     331  do ifils=1,tracers(iq)%nqDescen
     332    ! ! attention: comme Ratio est utilisé comme q dans l'appel
     333    ! ! recursif, il doit contenir à lui seul tous les indices de tous
     334    ! ! les descendants!
     335    iq2=tracers(iq)%iqDescen(ifils)
     336!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     337    DO l=1,llm
     338      DO ij=ijb,ije
     339        ! ! On a besoin de q et masse seulement entre ijb et ije. On ne
     340        ! ! les calcule donc que de ijb à ije
     341        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     342        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     343        if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
     344          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     345        else
     346          Ratio(ij,l,iq2)=min_ratio
     347        endif
    355348      enddo
    356 ! end CRisi
    357 
    358 
    359 c   calcul des tENDances
    360 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    361       DO l=1,llm
    362          DO ij=ijb+1,ije
    363             !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    364             new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
    365             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
    366      &        u_mq(ij-1,l)-u_mq(ij,l))
    367      &        /new_m
    368             masse(ij,l,iq)=new_m
    369          ENDDO
    370 c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
    371          DO ij=ijb+iip1-1,ije,iip1
    372             q(ij-iim,l,iq)=q(ij,l,iq)
    373             masse(ij-iim,l,iq)=masse(ij,l,iq)
    374          ENDDO
    375       ENDDO
    376 c$OMP END DO NOWAIT
    377 
    378 ! retablir les fils en rapport de melange par rapport a l'air:
    379       ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio
    380       ! puis on boucle en longitude
    381       do ifils=1,tracers(iq)%nqDescen
    382         iq2=tracers(iq)%iqDescen(ifils)
    383 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    384         DO l=1,llm
    385           DO ij=ijb+1,ije
    386             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    387           enddo
    388           DO ij=ijb+iip1-1,ije,iip1
    389             q(ij-iim,l,iq2)=q(ij,l,iq2)
    390           enddo
    391         enddo
    392 c$OMP END DO NOWAIT
     349    enddo
     350!$OMP END DO NOWAIT
     351  enddo !do ifils=1,tracers(iq)%nqDescen
     352  do ifils=1,tracers(iq)%nqChildren
     353    iq2=tracers(iq)%iqDescen(ifils)
     354    call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
     355  enddo
     356  ! end CRisi
     357
     358
     359  !   calcul des tENDances
     360!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     361  DO l=1,llm
     362     DO ij=ijb+1,ije
     363        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     364        new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
     365        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ &
     366              u_mq(ij-1,l)-u_mq(ij,l)) &
     367              /new_m
     368        masse(ij,l,iq)=new_m
     369     ENDDO
     370  !   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
     371     DO ij=ijb+iip1-1,ije,iip1
     372        q(ij-iim,l,iq)=q(ij,l,iq)
     373        masse(ij-iim,l,iq)=masse(ij,l,iq)
     374     ENDDO
     375  ENDDO
     376!$OMP END DO NOWAIT
     377
     378  ! retablir les fils en rapport de melange par rapport a l'air:
     379  ! ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio
     380  ! ! puis on boucle en longitude
     381  do ifils=1,tracers(iq)%nqDescen
     382    iq2=tracers(iq)%iqDescen(ifils)
     383!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     384    DO l=1,llm
     385      DO ij=ijb+1,ije
     386        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
    393387      enddo
    394 
    395       !write(*,*) 'vlsplt 399: iq,ijb_x=',iq,ijb_x
    396 c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    397 c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
    398 
    399 
    400       RETURN
    401       END
    402 
    403 
    404       RECURSIVE SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v,iq)
    405 c
    406 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    407 c
    408 c    ********************************************************************
    409 c     Shema  d'advection " pseudo amont " .
    410 c    ********************************************************************
    411 c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
    412 c     dq               sont des arguments de sortie pour le s-pg ....
    413 c
    414 c
    415 c   --------------------------------------------------------------------
    416       USE parallel_lmdz
    417       USE infotrac, ONLY : nqtot,tracers, ! CRisi                 &
    418      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi   
    419       USE comconst_mod, ONLY: pi
    420       IMPLICIT NONE
    421 c
    422       include "dimensions.h"
    423       include "paramet.h"
    424       include "comgeom.h"
    425 c
    426 c
    427 c   Arguments:
    428 c   ----------
    429       REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
    430       REAL masse_adv_v( ijb_v:ije_v,llm)
    431       REAL q(ijb_u:ije_u,llm,nqtot), dq( ijb_u:ije_u,llm)
    432       INTEGER iq ! CRisi
    433 c
    434 c      Local
    435 c   ---------
    436 c
    437       INTEGER i,ij,l
    438 c
    439       REAL airej2,airejjm,airescb(iim),airesch(iim)
    440       REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v),zdvm(ijb_u:ije_u,llm)
    441       REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
    442       REAL qbyv(ijb_v:ije_v,llm)
    443 
    444       REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
    445 c     REAL newq,oldmasse
    446       Logical extremum,first,testcpu
    447       REAL temps0,temps1,temps2,temps3,temps4,temps5,second
    448       SAVE temps0,temps1,temps2,temps3,temps4,temps5
    449 c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
    450       SAVE first,testcpu
    451 c$OMP THREADPRIVATE(first,testcpu)
    452 
    453       REAL convpn,convps,convmpn,convmps
    454       real massepn,masseps,qpn,qps
    455       REAL sinlon(iip1),sinlondlon(iip1)
    456       REAL coslon(iip1),coslondlon(iip1)
    457       SAVE sinlon,coslon,sinlondlon,coslondlon
    458 c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
    459       SAVE airej2,airejjm
    460 c$OMP THREADPRIVATE(airej2,airejjm)
    461 
    462       REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
    463       INTEGER ifils,iq2 ! CRisi
    464 c
    465 c
    466       REAL      SSUM
    467       EXTERNAL  SSUM
    468 
    469       DATA first,testcpu/.true.,.false./
    470       DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
    471       INTEGER ijb,ije
    472       INTEGER ijbm,ijem
    473 
    474       ijb=ij_begin-2*iip1
    475       ije=ij_end+2*iip1 
    476       if (pole_nord) ijb=ij_begin
    477       if (pole_sud)  ije=ij_end
    478 
    479       IF(first) THEN
    480          PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
    481          first=.false.
    482          do i=2,iip1
    483             coslon(i)=cos(rlonv(i))
    484             sinlon(i)=sin(rlonv(i))
    485             coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
    486             sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
    487          ENDDO
    488          coslon(1)=coslon(iip1)
    489          coslondlon(1)=coslondlon(iip1)
    490          sinlon(1)=sinlon(iip1)
    491          sinlondlon(1)=sinlondlon(iip1)
    492          airej2 = SSUM( iim, aire(iip2), 1 )
    493          airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
     388      DO ij=ijb+iip1-1,ije,iip1
     389        q(ij-iim,l,iq2)=q(ij,l,iq2)
     390      enddo
     391    enddo
     392!$OMP END DO NOWAIT
     393  enddo
     394
     395  ! !write(*,*) 'vlsplt 399: iq,ijb_x=',iq,ijb_x
     396  ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
     397  ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
     398
     399
     400  RETURN
     401END SUBROUTINE vlx_loc
     402
     403
     404RECURSIVE SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v,iq)
     405  !
     406  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     407  !
     408  !    ********************************************************************
     409  ! Shema  d'advection " pseudo amont " .
     410  !    ********************************************************************
     411  ! q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
     412  ! dq         sont des arguments de sortie pour le s-pg ....
     413  !
     414  !
     415  !   --------------------------------------------------------------------
     416  USE parallel_lmdz
     417  USE infotrac, ONLY : nqtot,tracers, & ! CRisi                 &
     418        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     419  USE comconst_mod, ONLY: pi
     420  IMPLICIT NONE
     421  !
     422  include "dimensions.h"
     423  include "paramet.h"
     424  include "comgeom.h"
     425  !
     426  !
     427  !   Arguments:
     428  !   ----------
     429  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
     430  REAL :: masse_adv_v( ijb_v:ije_v,llm)
     431  REAL :: q(ijb_u:ije_u,llm,nqtot), dq( ijb_u:ije_u,llm)
     432  INTEGER :: iq ! CRisi
     433  !
     434  !  Local
     435  !   ---------
     436  !
     437  INTEGER :: i,ij,l
     438  !
     439  REAL :: airej2,airejjm,airescb(iim),airesch(iim)
     440  REAL :: dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v),zdvm(ijb_u:ije_u,llm)
     441  REAL :: adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
     442  REAL :: qbyv(ijb_v:ije_v,llm)
     443
     444  REAL :: qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
     445  ! REAL newq,oldmasse
     446  Logical :: extremum,first,testcpu
     447  REAL :: temps0,temps1,temps2,temps3,temps4,temps5,second
     448  SAVE temps0,temps1,temps2,temps3,temps4,temps5
     449!$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
     450  SAVE first,testcpu
     451!$OMP THREADPRIVATE(first,testcpu)
     452
     453  REAL :: convpn,convps,convmpn,convmps
     454  real :: massepn,masseps,qpn,qps
     455  REAL :: sinlon(iip1),sinlondlon(iip1)
     456  REAL :: coslon(iip1),coslondlon(iip1)
     457  SAVE sinlon,coslon,sinlondlon,coslondlon
     458!$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
     459  SAVE airej2,airejjm
     460!$OMP THREADPRIVATE(airej2,airejjm)
     461
     462  REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
     463  INTEGER :: ifils,iq2 ! CRisi
     464  !
     465  !
     466  REAL :: SSUM
     467  EXTERNAL  SSUM
     468
     469  DATA first,testcpu/.true.,.false./
     470  DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
     471  INTEGER :: ijb,ije
     472  INTEGER :: ijbm,ijem
     473
     474  ijb=ij_begin-2*iip1
     475  ije=ij_end+2*iip1
     476  if (pole_nord) ijb=ij_begin
     477  if (pole_sud)  ije=ij_end
     478
     479  IF(first) THEN
     480     PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
     481     first=.false.
     482     do i=2,iip1
     483        coslon(i)=cos(rlonv(i))
     484        sinlon(i)=sin(rlonv(i))
     485        coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
     486        sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
     487     ENDDO
     488     coslon(1)=coslon(iip1)
     489     coslondlon(1)=coslondlon(iip1)
     490     sinlon(1)=sinlon(iip1)
     491     sinlondlon(1)=sinlondlon(iip1)
     492     airej2 = SSUM( iim, aire(iip2), 1 )
     493     airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
     494  ENDIF
     495
     496  !
     497  ! PRINT*,'CALCUL EN LATITUDE'
     498
     499!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     500  DO l = 1, llm
     501  !
     502  !   --------------------------------
     503  !  CALCUL EN LATITUDE
     504  !   --------------------------------
     505
     506  !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
     507  !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
     508  !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
     509
     510  if (pole_nord) then
     511    DO i = 1, iim
     512      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
     513    ENDDO
     514    qpns   = SSUM( iim,  airescb ,1 ) / airej2
     515  endif
     516
     517  if (pole_sud) then
     518    DO i = 1, iim
     519      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
     520    ENDDO
     521    qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
     522  endif
     523
     524  !   calcul des pentes aux points v
     525
     526  ijb=ij_begin-2*iip1
     527  ije=ij_end+iip1
     528  if (pole_nord) ijb=ij_begin
     529  if (pole_sud)  ije=ij_end-iip1
     530
     531  ! ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1
     532  ! ! Si pole sud, entre ij_begin-2*iip1 et ij_end
     533  ! ! Si pole Nord, entre ij_begin et ij_end+2*iip1
     534  DO ij=ijb,ije
     535     dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
     536     adyqv(ij)=abs(dyqv(ij))
     537  ENDDO
     538
     539
     540  !   calcul des pentes aux points scalaires
     541  ijb=ij_begin-iip1
     542  ije=ij_end+iip1
     543  if (pole_nord) ijb=ij_begin+iip1
     544  if (pole_sud)  ije=ij_end-iip1
     545
     546  DO ij=ijb,ije
     547     dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
     548     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
     549     dyqmax(ij)=pente_max*dyqmax(ij)
     550  ENDDO
     551
     552  !   calcul des pentes aux poles
     553  IF (pole_nord) THEN
     554    DO ij=1,iip1
     555       dyq(ij,l)=qpns-q(ij+iip1,l,iq)
     556    ENDDO
     557
     558    dyn1=0.
     559    dyn2=0.
     560    DO ij=1,iim
     561      dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
     562      dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
     563    ENDDO
     564    DO ij=1,iip1
     565      dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
     566    ENDDO
     567
     568    DO ij=1,iip1
     569     dyq(ij,l)=0.
     570    ENDDO
     571  ! ym tout cela ne sert pas a grand chose
     572  ENDIF
     573
     574  IF (pole_sud) THEN
     575
     576    DO ij=1,iip1
     577       dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
     578    ENDDO
     579
     580    dys1=0.
     581    dys2=0.
     582
     583    DO ij=1,iim
     584      dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
     585      dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
     586    ENDDO
     587
     588    DO ij=1,iip1
     589      dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
     590    ENDDO
     591
     592    DO ij=1,iip1
     593     dyq(ip1jm+ij,l)=0.
     594    ENDDO
     595  ! ym tout cela ne sert pas a grand chose
     596  ENDIF
     597
     598  !   filtrage de la derivee
     599
     600  !   calcul des pentes limites aux poles
     601  ! ym partie inutile
     602   ! goto 8888
     603   ! fn=1.
     604   ! fs=1.
     605   ! DO ij=1,iim
     606   !    IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
     607   !       fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
     608   !    ENDIF
     609   ! IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
     610   !    fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
     611   !    ENDIF
     612   ! ENDDO
     613   ! DO ij=1,iip1
     614   !    dyq(ij,l)=fn*dyq(ij,l)
     615   !    dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
     616   ! ENDDO
     617  ! 8888    continue
     618
     619
     620  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     621  !  En memoire de dIFferents tests sur la
     622  !  limitation des pentes aux poles.
     623  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     624  ! PRINT*,dyq(1)
     625  ! PRINT*,dyqv(iip1+1)
     626  ! appn=abs(dyq(1)/dyqv(iip1+1))
     627  ! PRINT*,dyq(ip1jm+1)
     628  ! PRINT*,dyqv(ip1jm-iip1+1)
     629  ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
     630  ! DO ij=2,iim
     631  !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
     632  !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
     633  ! ENDDO
     634  ! appn=min(pente_max/appn,1.)
     635  ! apps=min(pente_max/apps,1.)
     636  !
     637  !
     638  !   cas ou on a un extremum au pole
     639  !
     640  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     641  !    &   appn=0.
     642  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     643  !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     644  !    &   apps=0.
     645  !
     646  !   limitation des pentes aux poles
     647  ! DO ij=1,iip1
     648  !    dyq(ij)=appn*dyq(ij)
     649  !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
     650  ! ENDDO
     651  !
     652  !   test
     653  !  DO ij=1,iip1
     654  !     dyq(iip1+ij)=0.
     655  !     dyq(ip1jm+ij-iip1)=0.
     656  !  ENDDO
     657  !  DO ij=1,ip1jmp1
     658  !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
     659  !  ENDDO
     660  !
     661  ! changement 10 07 96
     662  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     663  !    &   THEN
     664  !    DO ij=1,iip1
     665  !       dyqmax(ij)=0.
     666  !    ENDDO
     667  ! ELSE
     668  !    DO ij=1,iip1
     669  !       dyqmax(ij)=pente_max*abs(dyqv(ij))
     670  !    ENDDO
     671  ! ENDIF
     672  !
     673  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     674  !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     675  !    &THEN
     676  !    DO ij=ip1jm+1,ip1jmp1
     677  !       dyqmax(ij)=0.
     678  !    ENDDO
     679  ! ELSE
     680  !    DO ij=ip1jm+1,ip1jmp1
     681  !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
     682  !    ENDDO
     683  ! ENDIF
     684  !   fin changement 10 07 96
     685  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     686
     687  !   calcul des pentes limitees
     688  ijb=ij_begin-iip1
     689  ije=ij_end+iip1
     690  if (pole_nord) ijb=ij_begin+iip1
     691  if (pole_sud)  ije=ij_end-iip1
     692
     693  DO ij=ijb,ije
     694     IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
     695        dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
     696     ELSE
     697        dyq(ij,l)=0.
     698     ENDIF
     699  ENDDO
     700
     701  ENDDO
     702!$OMP END DO NOWAIT
     703
     704  ijb=ij_begin-iip1
     705  ije=ij_end
     706  if (pole_nord) ijb=ij_begin
     707  if (pole_sud)  ije=ij_end-iip1
     708
     709!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     710  DO l=1,llm
     711   DO ij=ijb,ije
     712      IF(masse_adv_v(ij,l).gt.0) THEN
     713          qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)* &
     714                0.5*(1.-masse_adv_v(ij,l) &
     715                /masse(ij+iip1,l,iq))
     716      ELSE
     717          qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)* &
     718                0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq))
    494719      ENDIF
    495 
    496 c
    497 c       PRINT*,'CALCUL EN LATITUDE'
    498 
    499 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
    500       DO l = 1, llm
    501 c
    502 c   --------------------------------
    503 c      CALCUL EN LATITUDE
    504 c   --------------------------------
    505 
    506 c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
    507 c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
    508 c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
    509      
    510       if (pole_nord) then
    511         DO i = 1, iim
    512           airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
    513         ENDDO
    514         qpns   = SSUM( iim,  airescb ,1 ) / airej2
    515       endif
    516      
    517       if (pole_sud) then
    518         DO i = 1, iim
    519           airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    520         ENDDO
    521         qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
    522       endif
    523      
    524 c   calcul des pentes aux points v
    525 
    526       ijb=ij_begin-2*iip1
    527       ije=ij_end+iip1
    528       if (pole_nord) ijb=ij_begin
    529       if (pole_sud)  ije=ij_end-iip1
    530      
    531       ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1
    532       ! Si pole sud, entre ij_begin-2*iip1 et ij_end
    533       ! Si pole Nord, entre ij_begin et ij_end+2*iip1
     720      qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
     721   ENDDO
     722  ENDDO
     723!$OMP END DO NOWAIT
     724
     725  ! CRisi: appel récursif de l'advection sur les fils.
     726  ! Il faut faire ça avant d'avoir mis à jour q et masse
     727  ! write(*,*)'vly 689: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren
     728
     729  ijb=ij_begin-2*iip1
     730  ije=ij_end+2*iip1
     731  ijbm=ij_begin-iip1
     732  ijem=ij_end+iip1
     733  if (pole_nord) ijb=ij_begin
     734  if (pole_sud)  ije=ij_end
     735  if (pole_nord) ijbm=ij_begin
     736  if (pole_sud)  ijem=ij_end
     737
     738  do ifils=1,tracers(iq)%nqDescen
     739    iq2=tracers(iq)%iqDescen(ifils)
     740!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     741    DO l=1,llm
     742    ! ! modif des bornes: CRisi 16 nov 2020
     743    ! ! d'abord masse avec bornes corrigées
     744      DO ij=ijbm,ijem
     745      ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     746        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     747      enddo
     748
     749      ! ! ensuite Ratio avec anciennes bornes
    534750      DO ij=ijb,ije
    535          dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    536          adyqv(ij)=abs(dyqv(ij))
    537       ENDDO
    538  
    539 
    540 c   calcul des pentes aux points scalaires
    541       ijb=ij_begin-iip1
    542       ije=ij_end+iip1
    543       if (pole_nord) ijb=ij_begin+iip1
    544       if (pole_sud)  ije=ij_end-iip1
    545      
     751      ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     752        if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
     753          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     754        else
     755          Ratio(ij,l,iq2)=min_ratio
     756        endif
     757      enddo !DO ij=ijbm,ijem
     758    enddo !DO l=1,llm
     759!$OMP END DO NOWAIT
     760  enddo
     761
     762  do ifils=1,tracers(iq)%nqChildren
     763    iq2=tracers(iq)%iqDescen(ifils)
     764    call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
     765  enddo
     766  ! end CRisi
     767
     768  ijb=ij_begin
     769  ije=ij_end
     770  if (pole_nord) ijb=ij_begin+iip1
     771  if (pole_sud)  ije=ij_end-iip1
     772
     773!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     774  DO l=1,llm
     775     DO ij=ijb,ije
     776        newmasse=masse(ij,l,iq) &
     777              +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
     778
     779        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l) &
     780              -qbyv(ij-iip1,l))/newmasse
     781
     782        masse(ij,l,iq)=newmasse
     783
     784     ENDDO
     785
     786
     787  !.-. ancienne version
     788     ! convpn=SSUM(iim,qbyv(1,l),1)/apoln
     789     ! convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
     790     if (pole_nord) then
     791       convpn=SSUM(iim,qbyv(1,l),1)
     792       convmpn=ssum(iim,masse_adv_v(1,l),1)
     793       massepn=ssum(iim,masse(1,l,iq),1)
     794       qpn=0.
     795       do ij=1,iim
     796          qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
     797       enddo
     798       qpn=(qpn+convpn)/(massepn+convmpn)
     799       do ij=1,iip1
     800          q(ij,l,iq)=qpn
     801       enddo
     802     endif
     803
     804     ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
     805     ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
     806
     807     if (pole_sud) then
     808
     809       convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
     810       convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
     811       masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
     812       qps=0.
     813       do ij = ip1jm+1,ip1jmp1-1
     814          qps=qps+masse(ij,l,iq)*q(ij,l,iq)
     815       enddo
     816       qps=(qps+convps)/(masseps+convmps)
     817       do ij=ip1jm+1,ip1jmp1
     818          q(ij,l,iq)=qps
     819       enddo
     820     endif
     821  !.-. fin ancienne version
     822
     823  !._. nouvelle version
     824     ! convpn=SSUM(iim,qbyv(1,l),1)
     825     ! convmpn=ssum(iim,masse_adv_v(1,l),1)
     826     ! oldmasse=ssum(iim,masse(1,l),1)
     827     ! newmasse=oldmasse+convmpn
     828     ! newq=(q(1,l)*oldmasse+convpn)/newmasse
     829     ! newmasse=newmasse/apoln
     830     ! DO ij = 1,iip1
     831     !    q(ij,l)=newq
     832     !    masse(ij,l,iq)=newmasse*aire(ij)
     833     ! ENDDO
     834     ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
     835     ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
     836     ! oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
     837     ! newmasse=oldmasse+convmps
     838     ! newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
     839     ! newmasse=newmasse/apols
     840     ! DO ij = ip1jm+1,ip1jmp1
     841     !    q(ij,l)=newq
     842     !    masse(ij,l,iq)=newmasse*aire(ij)
     843     ! ENDDO
     844  !._. fin nouvelle version
     845  ENDDO
     846!$OMP END DO NOWAIT
     847
     848  ! retablir les fils en rapport de melange par rapport a l'air:
     849  ijb=ij_begin
     850  ije=ij_end
     851   ! if (pole_nord) ijb=ij_begin
     852   ! if (pole_sud)  ije=ij_end
     853
     854  do ifils=1,tracers(iq)%nqDescen
     855    iq2=tracers(iq)%iqDescen(ifils)
     856!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     857    DO l=1,llm
    546858      DO ij=ijb,ije
    547          dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
    548          dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
    549          dyqmax(ij)=pente_max*dyqmax(ij)
    550       ENDDO
    551 
    552 c   calcul des pentes aux poles
    553       IF (pole_nord) THEN
    554         DO ij=1,iip1
    555            dyq(ij,l)=qpns-q(ij+iip1,l,iq)
    556         ENDDO
    557        
    558         dyn1=0.
    559         dyn2=0.
    560         DO ij=1,iim
    561           dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
    562           dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
    563         ENDDO
    564         DO ij=1,iip1
    565           dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
    566         ENDDO
    567        
    568         DO ij=1,iip1
    569          dyq(ij,l)=0.
    570         ENDDO
    571 c ym tout cela ne sert pas a grand chose
     859        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
     860      enddo
     861    enddo
     862!$OMP END DO NOWAIT
     863  enddo
     864
     865
     866  RETURN
     867END SUBROUTINE vly_loc
     868
     869
     870
     871RECURSIVE SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x,iq)
     872  !
     873  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     874  !
     875  !    ********************************************************************
     876  ! Shema  d'advection " pseudo amont " .
     877  !    ********************************************************************
     878  !    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     879  ! dq         sont des arguments de sortie pour le s-pg ....
     880  !
     881  !
     882  !   --------------------------------------------------------------------
     883  USE parallel_lmdz
     884  USE vlz_mod
     885  USE infotrac, ONLY : nqtot,tracers, & ! CRisi                 &
     886        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     887
     888  IMPLICIT NONE
     889  !
     890  include "dimensions.h"
     891  include "paramet.h"
     892  include "iniprint.h"
     893  !
     894  !
     895  !   Arguments:
     896  !   ----------
     897  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
     898  REAL :: q(ijb_u:ije_u,llm,nqtot)
     899  REAL :: w(ijb_u:ije_u,llm+1,nqtot)
     900  INTEGER :: iq
     901  !
     902  !  Local
     903  !   ---------
     904  !
     905  INTEGER :: i,ij,l,j,ii
     906
     907  REAL,DIMENSION(ijb_u:ije_u,llm+1) :: wresi,morig,qorig,dzqorig
     908  INTEGER,DIMENSION(ijb_u:ije_u,llm+1) :: lorig
     909  INTEGER,SAVE :: countcfl
     910!$OMP THREADPRIVATE(countcfl)
     911  !
     912  REAL :: newmasse
     913
     914  REAL :: dzqmax
     915  REAL :: sigw
     916
     917  LOGICAL :: testcpu
     918  SAVE testcpu
     919!$OMP THREADPRIVATE(testcpu)
     920  REAL :: temps0,temps1,temps2,temps3,temps4,temps5,second
     921  SAVE temps0,temps1,temps2,temps3,temps4,temps5
     922!$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
     923
     924  REAL :: SSUM
     925  EXTERNAL  SSUM
     926
     927  DATA testcpu/.false./
     928  DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
     929  INTEGER :: ijb,ije,ijb_x,ije_x
     930  LOGICAL,SAVE :: first=.TRUE.
     931!$OMP THREADPRIVATE(first)
     932
     933  ! !REAL masseq(ijb_u:ije_u,llm,nqtot),Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
     934  ! ! Ces varibles doivent être déclarées en pointer et en save dans
     935  ! ! vlz_loc si on veut qu'elles soient vues par tous les threads.
     936  INTEGER :: ifils,iq2 ! CRisi
     937
     938
     939  IF (first) THEN
     940   first=.FALSE.
     941  ENDIF
     942  !    On oriente tout dans le sens de la pression c'est a dire dans le
     943  !    sens de W
     944
     945  ! !write(*,*) 'vlsplt 926: entree dans vlz_loc, iq=',iq
     946#ifdef BIDON
     947  IF(testcpu) THEN
     948     temps0=second(0.)
     949  ENDIF
     950#endif
     951
     952  ijb=ijb_x
     953  ije=ije_x
     954
     955!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     956  DO l=2,llm
     957     DO ij=ijb,ije
     958        dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
     959        adzqw(ij,l)=abs(dzqw(ij,l))
     960     ENDDO
     961  ENDDO
     962!$OMP END DO
     963
     964!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     965  DO l=2,llm-1
     966     DO ij=ijb,ije
     967#ifdef CRAY
     968        dzq(ij,l)=0.5* &
     969              cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
     970#else
     971        IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
     972            dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
     973        ELSE
     974            dzq(ij,l)=0.
     975        ENDIF
     976#endif
     977        dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
     978        dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
     979     ENDDO
     980  ENDDO
     981!$OMP END DO NOWAIT
     982
     983!$OMP MASTER
     984  DO ij=ijb,ije
     985     dzq(ij,1)=0.
     986     dzq(ij,llm)=0.
     987  ENDDO
     988!$OMP END MASTER
     989!$OMP BARRIER
     990#ifdef BIDON
     991  IF(testcpu) THEN
     992     temps1=temps1+second(0.)-temps0
     993  ENDIF
     994#endif
     995
     996  !--------------------------------------------------------
     997  ! On repere les points qui violent le CFL (|w| > masse)
     998  !--------------------------------------------------------
     999
     1000  countcfl=0
     1001  ! print*,'vlz nouveau'
     1002!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1003  DO l = 2,llm
     1004     DO ij = ijb,ije
     1005      IF(  (w(ij,l,iq)>0.AND.w(ij,l,iq)>masse(ij,l,iq)) &
     1006            .OR. (w(ij,l,iq)<=0.AND.ABS(w(ij,l,iq))>masse(ij,l-1,iq)) ) &
     1007            countcfl=countcfl+1
     1008     ENDDO
     1009  ENDDO
     1010!$OMP END DO NOWAIT
     1011
     1012  ! ---------------------------------------------------------------
     1013  !  Identification des mailles ou on viole le CFL : w > masse
     1014  ! ---------------------------------------------------------------
     1015
     1016  IF (countcfl==0) THEN
     1017
     1018  ! ---------------------------------------------------------------
     1019  !   .... calcul des termes d'advection verticale  .......
     1020  ! Dans le cas où le  |w| < masse partout.
     1021  ! Version d'origine
     1022  ! Pourrait etre enleve si on voit que le code plus general
     1023  ! est aussi rapide
     1024  ! ---------------------------------------------------------------
     1025
     1026  ! calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
     1027
     1028  !  !write(*,*) 'vlz 982,ijb,ije=',ijb,ije
     1029!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1030   DO l = 1,llm-1
     1031     do  ij = ijb,ije
     1032      IF(w(ij,l+1,iq).gt.0.) THEN
     1033         sigw=w(ij,l+1,iq)/masse(ij,l+1,iq)
     1034         wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l+1,iq) &
     1035               +0.5*(1.-sigw)*dzq(ij,l+1))
     1036      ELSE
     1037         sigw=w(ij,l+1,iq)/masse(ij,l,iq)
     1038         wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l,iq) &
     1039               -0.5*(1.+sigw)*dzq(ij,l))
    5721040      ENDIF
    573      
    574       IF (pole_sud) THEN
    575 
    576         DO ij=1,iip1
    577            dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    578         ENDDO
    579 
    580         dys1=0.
    581         dys2=0.
    582 
    583         DO ij=1,iim
    584           dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
    585           dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
    586         ENDDO
    587 
    588         DO ij=1,iip1
    589           dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
    590         ENDDO
    591        
    592         DO ij=1,iip1
    593          dyq(ip1jm+ij,l)=0.
    594         ENDDO
    595 c ym tout cela ne sert pas a grand chose
     1041     ENDDO
     1042   ENDDO
     1043!$OMP END DO NOWAIT
     1044   ! !write(*,*) 'vlz 1001'
     1045
     1046  ELSE ! countcfl>=1
     1047
     1048  IF (prt_level>9) THEN
     1049    WRITE(lunout,*)'vlz passage dans le non local'
     1050  ENDIF
     1051  ! ---------------------------------------------------------------
     1052  !  Debut du traitement du cas ou on viole le CFL : w > masse
     1053  ! ---------------------------------------------------------------
     1054
     1055  ! Initialisation
     1056
     1057!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1058   DO l = 2,llm
     1059     DO ij = ijb,ije
     1060        wresi(ij,l)=w(ij,l,iq)
     1061        wq(ij,l,iq)=0.
     1062        IF(w(ij,l,iq).gt.0.) THEN
     1063           lorig(ij,l)=l
     1064           morig(ij,l)=masse(ij,l,iq)
     1065           qorig(ij,l)=q(ij,l,iq)
     1066           dzqorig(ij,l)=dzq(ij,l)
     1067        ELSE
     1068           lorig(ij,l)=l-1
     1069           morig(ij,l)=masse(ij,l-1,iq)
     1070           qorig(ij,l)=q(ij,l-1,iq)
     1071           dzqorig(ij,l)=dzq(ij,l-1)
     1072        ENDIF
     1073     ENDDO
     1074   ENDDO
     1075!$OMP END DO NOWAIT
     1076
     1077  ! Reindicage vertical en accumulant les flux sur
     1078  !  les mailles qui viollent le CFL
     1079  !  on itère jusqu'à ce que tous les poins satisfassent
     1080  !  le critère
     1081  DO WHILE (countcfl>=1)
     1082    IF (prt_level>9) THEN
     1083      WRITE(lunout,*)'On viole le CFL Vertical sur ',countcfl,' pts'
     1084    ENDIF
     1085  countcfl=0
     1086
     1087!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1088  DO l = 2,llm
     1089     DO ij = ijb,ije
     1090      IF (ABS(wresi(ij,l))>morig(ij,l)) THEN
     1091         countcfl=countcfl+1
     1092  ! rm : les 8 lignes ci dessous pourraient sans doute s'ecrire
     1093  ! avec la fonction sign
     1094         IF(w(ij,l,iq)>0.) THEN
     1095            wresi(ij,l)=wresi(ij,l)-morig(ij,l)
     1096            wq(ij,l,iq)=wq(ij,l,iq)+morig(ij,l)*qorig(ij,l)
     1097            lorig(ij,l)=lorig(ij,l)+1
     1098         ELSE
     1099            wresi(ij,l)=wresi(ij,l)+morig(ij,l)
     1100            wq(ij,l,iq)=wq(ij,l,iq)-morig(ij,l)*qorig(ij,l)
     1101            lorig(ij,l)=lorig(ij,l)-1
     1102         ENDIF
     1103         ! ! CRisi 24nov2020: ajout d'un message d'erreur clair au lieu d'un plantage
     1104         ! ! pour seg fault
     1105         if (lorig(ij,l).eq.0) then
     1106            call abort_gcm("vlz in vlsplt_loc", &
     1107                  "unfixable violation of CFL",1)
     1108         endif
     1109         morig(ij,l)=masse(ij,lorig(ij,l),iq)
     1110         qorig(ij,l)=q(ij,lorig(ij,l),iq)
     1111         dzqorig(ij,l)=dzq(ij,lorig(ij,l))
    5961112      ENDIF
    597 
    598 c   filtrage de la derivee
    599 
    600 c   calcul des pentes limites aux poles
    601 c ym partie inutile
    602 c      goto 8888
    603 c      fn=1.
    604 c      fs=1.
    605 c      DO ij=1,iim
    606 c         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
    607 c            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
    608 c         ENDIF
    609 c      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
    610 c         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
    611 c         ENDIF
    612 c      ENDDO
    613 c      DO ij=1,iip1
    614 c         dyq(ij,l)=fn*dyq(ij,l)
    615 c         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
    616 c      ENDDO
    617 c 8888    continue
    618 
    619 
    620 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    621 C  En memoire de dIFferents tests sur la
    622 C  limitation des pentes aux poles.
    623 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    624 C     PRINT*,dyq(1)
    625 C     PRINT*,dyqv(iip1+1)
    626 C     appn=abs(dyq(1)/dyqv(iip1+1))
    627 C     PRINT*,dyq(ip1jm+1)
    628 C     PRINT*,dyqv(ip1jm-iip1+1)
    629 C     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
    630 C     DO ij=2,iim
    631 C        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
    632 C        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
    633 C     ENDDO
    634 C     appn=min(pente_max/appn,1.)
    635 C     apps=min(pente_max/apps,1.)
    636 C
    637 C
    638 C   cas ou on a un extremum au pole
    639 C
    640 C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    641 C    &   appn=0.
    642 C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    643 C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    644 C    &   apps=0.
    645 C
    646 C   limitation des pentes aux poles
    647 C     DO ij=1,iip1
    648 C        dyq(ij)=appn*dyq(ij)
    649 C        dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
    650 C     ENDDO
    651 C
    652 C   test
    653 C      DO ij=1,iip1
    654 C         dyq(iip1+ij)=0.
    655 C         dyq(ip1jm+ij-iip1)=0.
    656 C      ENDDO
    657 C      DO ij=1,ip1jmp1
    658 C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
    659 C      ENDDO
    660 C
    661 C changement 10 07 96
    662 C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    663 C    &   THEN
    664 C        DO ij=1,iip1
    665 C           dyqmax(ij)=0.
    666 C        ENDDO
    667 C     ELSE
    668 C        DO ij=1,iip1
    669 C           dyqmax(ij)=pente_max*abs(dyqv(ij))
    670 C        ENDDO
    671 C     ENDIF
    672 C
    673 C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    674 C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    675 C    &THEN
    676 C        DO ij=ip1jm+1,ip1jmp1
    677 C           dyqmax(ij)=0.
    678 C        ENDDO
    679 C     ELSE
    680 C        DO ij=ip1jm+1,ip1jmp1
    681 C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
    682 C        ENDDO
    683 C     ENDIF
    684 C   fin changement 10 07 96
    685 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    686 
    687 c   calcul des pentes limitees
    688       ijb=ij_begin-iip1
    689       ije=ij_end+iip1
    690       if (pole_nord) ijb=ij_begin+iip1
    691       if (pole_sud)  ije=ij_end-iip1
    692 
     1113     ENDDO
     1114  ENDDO
     1115!$OMP END DO NOWAIT
     1116
     1117  ENDDO ! WHILE (countcfl>=1)
     1118
     1119!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1120   DO l = 2,llm
     1121     do  ij = ijb,ije
     1122      sigw=wresi(ij,l)/morig(ij,l)
     1123      IF(w(ij,l,iq).gt.0.) THEN
     1124         wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l) &
     1125               +0.5*(1.-sigw)*dzqorig(ij,l))
     1126      ELSE
     1127         wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l) &
     1128               -0.5*(1.+sigw)*dzqorig(ij,l))
     1129      ENDIF
     1130     ENDDO
     1131   ENDDO
     1132!$OMP END DO NOWAIT
     1133
     1134
     1135   ENDIF ! councfl=0
     1136
     1137
     1138
     1139!$OMP MASTER
     1140   DO ij=ijb,ije
     1141      wq(ij,llm+1,iq)=0.
     1142      wq(ij,1,iq)=0.
     1143   ENDDO
     1144!$OMP END MASTER
     1145!$OMP BARRIER
     1146
     1147  ! CRisi: appel récursif de l'advection sur les fils.
     1148  ! Il faut faire ça avant d'avoir mis à jour q et masse
     1149  ! write(*,*)'vlsplt 942: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren
     1150  do ifils=1,tracers(iq)%nqDescen
     1151    iq2=tracers(iq)%iqDescen(ifils)
     1152!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1153    DO l=1,llm
    6931154      DO ij=ijb,ije
    694          IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
    695             dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
    696          ELSE
    697             dyq(ij,l)=0.
    698          ENDIF
    699       ENDDO
    700 
    701       ENDDO
    702 c$OMP END DO NOWAIT
    703 
    704       ijb=ij_begin-iip1
    705       ije=ij_end
    706       if (pole_nord) ijb=ij_begin
    707       if (pole_sud)  ije=ij_end-iip1
    708 
    709 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    710       DO l=1,llm
    711        DO ij=ijb,ije
    712           IF(masse_adv_v(ij,l).gt.0) THEN
    713               qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)*
    714      ,                   0.5*(1.-masse_adv_v(ij,l)
    715      ,                   /masse(ij+iip1,l,iq))
    716           ELSE
    717               qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)*
    718      ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq))
    719           ENDIF
    720           qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
    721        ENDDO
    722       ENDDO
    723 c$OMP END DO NOWAIT
    724 
    725 ! CRisi: appel récursif de l'advection sur les fils.
    726 ! Il faut faire ça avant d'avoir mis à jour q et masse
    727 !     write(*,*)'vly 689: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren
    728 
    729       ijb=ij_begin-2*iip1
    730       ije=ij_end+2*iip1
    731       ijbm=ij_begin-iip1
    732       ijem=ij_end+iip1
    733       if (pole_nord) ijb=ij_begin
    734       if (pole_sud)  ije=ij_end 
    735       if (pole_nord) ijbm=ij_begin
    736       if (pole_sud)  ijem=ij_end
    737 
    738       do ifils=1,tracers(iq)%nqDescen
    739         iq2=tracers(iq)%iqDescen(ifils)
    740 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    741         DO l=1,llm
    742         ! modif des bornes: CRisi 16 nov 2020
    743         ! d'abord masse avec bornes corrigées
    744           DO ij=ijbm,ijem
    745           !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    746             masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    747           enddo
    748 
    749           ! ensuite Ratio avec anciennes bornes
    750           DO ij=ijb,ije
    751           !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    752             if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
    753               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    754             else
    755               Ratio(ij,l,iq2)=min_ratio 
    756             endif     
    757           enddo !DO ij=ijbm,ijem 
    758         enddo !DO l=1,llm
    759 c$OMP END DO NOWAIT
     1155       ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     1156        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     1157        if (q(ij,l,iq).gt.min_qParent) then
     1158          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     1159        else
     1160          Ratio(ij,l,iq2)=min_ratio
     1161        endif
     1162        ! !wq(ij,l,iq2)=wq(ij,l,iq) ! correction bug le 15mai2015
     1163        w(ij,l,iq2)=wq(ij,l,iq)
    7601164      enddo
    761 
    762       do ifils=1,tracers(iq)%nqChildren
    763         iq2=tracers(iq)%iqDescen(ifils)
    764         call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
     1165    enddo
     1166!$OMP END DO NOWAIT
     1167  enddo
     1168!$OMP BARRIER
     1169
     1170  do ifils=1,tracers(iq)%nqChildren
     1171    iq2=tracers(iq)%iqDescen(ifils)
     1172    call vlz_loc(Ratio,pente_max,masse,w,ijb_x,ije_x,iq2)
     1173  enddo
     1174  ! end CRisi
     1175
     1176  ! CRisi: On rajoute ici une barrière car on veut être sur que tous les
     1177  ! wq soient synchronisés
     1178
     1179!$OMP BARRIER
     1180!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1181  DO l=1,llm
     1182     DO ij=ijb,ije
     1183        newmasse=masse(ij,l,iq)+w(ij,l+1,iq)-w(ij,l,iq)
     1184        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq) &
     1185              +wq(ij,l+1,iq)-wq(ij,l,iq)) &
     1186              /newmasse
     1187        masse(ij,l,iq)=newmasse
     1188     ENDDO
     1189  ENDDO
     1190!$OMP END DO NOWAIT
     1191
     1192
     1193  ! retablir les fils en rapport de melange par rapport a l'air:
     1194  do ifils=1,tracers(iq)%nqDescen
     1195    iq2=tracers(iq)%iqDescen(ifils)
     1196!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1197    DO l=1,llm
     1198      DO ij=ijb,ije
     1199        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
    7651200      enddo
    766 ! end CRisi
    767      
    768       ijb=ij_begin
    769       ije=ij_end
    770       if (pole_nord) ijb=ij_begin+iip1
    771       if (pole_sud)  ije=ij_end-iip1
    772      
    773 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
    774       DO l=1,llm
    775          DO ij=ijb,ije
    776             newmasse=masse(ij,l,iq)
    777      &         +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    778 
    779             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
    780      &         -qbyv(ij-iip1,l))/newmasse
    781 
    782             masse(ij,l,iq)=newmasse
    783 
    784          ENDDO
    785 
    786 
    787 c.-. ancienne version
    788 c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
    789 c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
    790          if (pole_nord) then
    791            convpn=SSUM(iim,qbyv(1,l),1)
    792            convmpn=ssum(iim,masse_adv_v(1,l),1)
    793            massepn=ssum(iim,masse(1,l,iq),1)
    794            qpn=0.
    795            do ij=1,iim
    796               qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
    797            enddo
    798            qpn=(qpn+convpn)/(massepn+convmpn)
    799            do ij=1,iip1
    800               q(ij,l,iq)=qpn
    801            enddo
    802          endif
    803          
    804 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
    805 c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
    806          
    807          if (pole_sud) then
    808          
    809            convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    810            convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    811            masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
    812            qps=0.
    813            do ij = ip1jm+1,ip1jmp1-1
    814               qps=qps+masse(ij,l,iq)*q(ij,l,iq)
    815            enddo
    816            qps=(qps+convps)/(masseps+convmps)
    817            do ij=ip1jm+1,ip1jmp1
    818               q(ij,l,iq)=qps
    819            enddo
    820          endif
    821 c.-. fin ancienne version
    822 
    823 c._. nouvelle version
    824 c        convpn=SSUM(iim,qbyv(1,l),1)
    825 c        convmpn=ssum(iim,masse_adv_v(1,l),1)
    826 c        oldmasse=ssum(iim,masse(1,l),1)
    827 c        newmasse=oldmasse+convmpn
    828 c        newq=(q(1,l)*oldmasse+convpn)/newmasse
    829 c        newmasse=newmasse/apoln
    830 c        DO ij = 1,iip1
    831 c           q(ij,l)=newq
    832 c           masse(ij,l,iq)=newmasse*aire(ij)
    833 c        ENDDO
    834 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    835 c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    836 c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
    837 c        newmasse=oldmasse+convmps
    838 c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
    839 c        newmasse=newmasse/apols
    840 c        DO ij = ip1jm+1,ip1jmp1
    841 c           q(ij,l)=newq
    842 c           masse(ij,l,iq)=newmasse*aire(ij)
    843 c        ENDDO
    844 c._. fin nouvelle version
    845       ENDDO
    846 c$OMP END DO NOWAIT
    847 
    848 ! retablir les fils en rapport de melange par rapport a l'air:
    849       ijb=ij_begin
    850       ije=ij_end
    851 !      if (pole_nord) ijb=ij_begin
    852 !      if (pole_sud)  ije=ij_end
    853 
    854       do ifils=1,tracers(iq)%nqDescen
    855         iq2=tracers(iq)%iqDescen(ifils)
    856 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    857         DO l=1,llm
    858           DO ij=ijb,ije
    859             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    860           enddo
    861         enddo
    862 c$OMP END DO NOWAIT
    863       enddo
    864 
    865 
    866       RETURN
    867       END
    868      
    869      
    870      
    871       RECURSIVE SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x,iq)
    872 c
    873 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    874 c
    875 c    ********************************************************************
    876 c     Shema  d'advection " pseudo amont " .
    877 c    ********************************************************************
    878 c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    879 c     dq               sont des arguments de sortie pour le s-pg ....
    880 c
    881 c
    882 c   --------------------------------------------------------------------
    883       USE parallel_lmdz
    884       USE vlz_mod
    885       USE infotrac, ONLY : nqtot,tracers, ! CRisi                 &
    886      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    887      
    888       IMPLICIT NONE
    889 c
    890       include "dimensions.h"
    891       include "paramet.h"
    892       include "iniprint.h"
    893 c
    894 c
    895 c   Arguments:
    896 c   ----------
    897       REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
    898       REAL q(ijb_u:ije_u,llm,nqtot)
    899       REAL w(ijb_u:ije_u,llm+1,nqtot)
    900       INTEGER iq
    901 c
    902 c      Local
    903 c   ---------
    904 c
    905       INTEGER i,ij,l,j,ii
    906 
    907       REAL,DIMENSION(ijb_u:ije_u,llm+1) :: wresi,morig,qorig,dzqorig
    908       INTEGER,DIMENSION(ijb_u:ije_u,llm+1) :: lorig
    909       INTEGER,SAVE :: countcfl
    910 !$OMP THREADPRIVATE(countcfl)
    911 c
    912       REAL newmasse
    913 
    914       REAL dzqmax
    915       REAL sigw
    916 
    917       LOGICAL testcpu
    918       SAVE testcpu
    919 c$OMP THREADPRIVATE(testcpu)
    920       REAL temps0,temps1,temps2,temps3,temps4,temps5,second
    921       SAVE temps0,temps1,temps2,temps3,temps4,temps5
    922 c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
    923 
    924       REAL      SSUM
    925       EXTERNAL  SSUM
    926 
    927       DATA testcpu/.false./
    928       DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
    929       INTEGER ijb,ije,ijb_x,ije_x
    930       LOGICAL,SAVE :: first=.TRUE.
    931 !$OMP THREADPRIVATE(first)
    932 
    933       !REAL masseq(ijb_u:ije_u,llm,nqtot),Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
    934       ! Ces varibles doivent être déclarées en pointer et en save dans
    935       ! vlz_loc si on veut qu'elles soient vues par tous les threads. 
    936       INTEGER ifils,iq2 ! CRisi
    937 
    938 
    939       IF (first) THEN
    940        first=.FALSE.
    941       ENDIF             
    942 c    On oriente tout dans le sens de la pression c'est a dire dans le
    943 c    sens de W
    944 
    945       !write(*,*) 'vlsplt 926: entree dans vlz_loc, iq=',iq
    946 #ifdef BIDON
    947       IF(testcpu) THEN
    948          temps0=second(0.)
    949       ENDIF
    950 #endif
    951 
    952       ijb=ijb_x
    953       ije=ije_x
    954 
    955 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
    956       DO l=2,llm
    957          DO ij=ijb,ije
    958             dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
    959             adzqw(ij,l)=abs(dzqw(ij,l))
    960          ENDDO
    961       ENDDO
    962 c$OMP END DO
    963 
    964 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    965       DO l=2,llm-1
    966          DO ij=ijb,ije
    967 #ifdef CRAY
    968             dzq(ij,l)=0.5*
    969      ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
    970 #else
    971             IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
    972                 dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
    973             ELSE
    974                 dzq(ij,l)=0.
    975             ENDIF
    976 #endif
    977             dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
    978             dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
    979          ENDDO
    980       ENDDO
    981 c$OMP END DO NOWAIT
    982 
    983 c$OMP MASTER
    984       DO ij=ijb,ije
    985          dzq(ij,1)=0.
    986          dzq(ij,llm)=0.
    987       ENDDO
    988 c$OMP END MASTER
    989 c$OMP BARRIER
    990 #ifdef BIDON
    991       IF(testcpu) THEN
    992          temps1=temps1+second(0.)-temps0
    993       ENDIF
    994 #endif
    995 
    996 !--------------------------------------------------------
    997 ! On repere les points qui violent le CFL (|w| > masse)
    998 !--------------------------------------------------------
    999 
    1000       countcfl=0
    1001 !     print*,'vlz nouveau'
    1002 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1003       DO l = 2,llm
    1004          DO ij = ijb,ije
    1005           IF(  (w(ij,l,iq)>0.AND.w(ij,l,iq)>masse(ij,l,iq))
    1006      s    .OR. (w(ij,l,iq)<=0.AND.ABS(w(ij,l,iq))>masse(ij,l-1,iq)) )
    1007      s    countcfl=countcfl+1
    1008          ENDDO
    1009       ENDDO
    1010 c$OMP END DO NOWAIT   
    1011 
    1012 c ---------------------------------------------------------------
    1013 c  Identification des mailles ou on viole le CFL : w > masse
    1014 c ---------------------------------------------------------------
    1015 
    1016       IF (countcfl==0) THEN
    1017 
    1018 c ---------------------------------------------------------------
    1019 c   .... calcul des termes d'advection verticale  .......
    1020 c     Dans le cas où le  |w| < masse partout.
    1021 c     Version d'origine
    1022 c     Pourrait etre enleve si on voit que le code plus general
    1023 c     est aussi rapide
    1024 c ---------------------------------------------------------------
    1025 
    1026 c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
    1027 
    1028        !write(*,*) 'vlz 982,ijb,ije=',ijb,ije
    1029 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1030        DO l = 1,llm-1
    1031          do  ij = ijb,ije
    1032           IF(w(ij,l+1,iq).gt.0.) THEN
    1033              sigw=w(ij,l+1,iq)/masse(ij,l+1,iq)
    1034              wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l+1,iq)
    1035      :           +0.5*(1.-sigw)*dzq(ij,l+1))
    1036           ELSE
    1037              sigw=w(ij,l+1,iq)/masse(ij,l,iq)
    1038              wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l,iq)
    1039      :           -0.5*(1.+sigw)*dzq(ij,l))
    1040           ENDIF
    1041          ENDDO
    1042        ENDDO
    1043 c$OMP END DO NOWAIT   
    1044        !write(*,*) 'vlz 1001'   
    1045 
    1046       ELSE ! countcfl>=1
    1047 
    1048       IF (prt_level>9) THEN
    1049         WRITE(lunout,*)'vlz passage dans le non local'
    1050       ENDIF
    1051 c ---------------------------------------------------------------
    1052 c  Debut du traitement du cas ou on viole le CFL : w > masse
    1053 c ---------------------------------------------------------------
    1054 
    1055 c Initialisation
    1056 
    1057 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1058        DO l = 2,llm
    1059          DO ij = ijb,ije
    1060             wresi(ij,l)=w(ij,l,iq)
    1061             wq(ij,l,iq)=0.
    1062             IF(w(ij,l,iq).gt.0.) THEN
    1063                lorig(ij,l)=l
    1064                morig(ij,l)=masse(ij,l,iq)
    1065                qorig(ij,l)=q(ij,l,iq)
    1066                dzqorig(ij,l)=dzq(ij,l)
    1067             ELSE
    1068                lorig(ij,l)=l-1
    1069                morig(ij,l)=masse(ij,l-1,iq)
    1070                qorig(ij,l)=q(ij,l-1,iq)
    1071                dzqorig(ij,l)=dzq(ij,l-1)
    1072             ENDIF
    1073          ENDDO
    1074        ENDDO
    1075 c$OMP END DO NOWAIT
    1076 
    1077 c Reindicage vertical en accumulant les flux sur
    1078 c  les mailles qui viollent le CFL
    1079 c  on itère jusqu'à ce que tous les poins satisfassent
    1080 c  le critère
    1081       DO WHILE (countcfl>=1)
    1082         IF (prt_level>9) THEN
    1083           WRITE(lunout,*)'On viole le CFL Vertical sur ',countcfl,' pts'
    1084         ENDIF
    1085       countcfl=0
    1086 
    1087 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1088       DO l = 2,llm
    1089          DO ij = ijb,ije
    1090           IF (ABS(wresi(ij,l))>morig(ij,l)) THEN
    1091              countcfl=countcfl+1
    1092 ! rm : les 8 lignes ci dessous pourraient sans doute s'ecrire
    1093 ! avec la fonction sign
    1094              IF(w(ij,l,iq)>0.) THEN
    1095                 wresi(ij,l)=wresi(ij,l)-morig(ij,l)
    1096                 wq(ij,l,iq)=wq(ij,l,iq)+morig(ij,l)*qorig(ij,l)
    1097                 lorig(ij,l)=lorig(ij,l)+1
    1098              ELSE
    1099                 wresi(ij,l)=wresi(ij,l)+morig(ij,l)
    1100                 wq(ij,l,iq)=wq(ij,l,iq)-morig(ij,l)*qorig(ij,l)
    1101                 lorig(ij,l)=lorig(ij,l)-1
    1102              ENDIF
    1103              ! CRisi 24nov2020: ajout d'un message d'erreur clair au lieu d'un plantage
    1104              ! pour seg fault
    1105              if (lorig(ij,l).eq.0) then
    1106                 call abort_gcm("vlz in vlsplt_loc",
    1107      :           "unfixable violation of CFL",1)
    1108              endif
    1109              morig(ij,l)=masse(ij,lorig(ij,l),iq)
    1110              qorig(ij,l)=q(ij,lorig(ij,l),iq)
    1111              dzqorig(ij,l)=dzq(ij,lorig(ij,l))
    1112           ENDIF
    1113          ENDDO
    1114       ENDDO
    1115 c$OMP END DO NOWAIT
    1116 
    1117       ENDDO ! WHILE (countcfl>=1)
    1118 
    1119 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1120        DO l = 2,llm
    1121          do  ij = ijb,ije
    1122           sigw=wresi(ij,l)/morig(ij,l)
    1123           IF(w(ij,l,iq).gt.0.) THEN
    1124              wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l)
    1125      :           +0.5*(1.-sigw)*dzqorig(ij,l))
    1126           ELSE
    1127              wq(ij,l,iq)=wq(ij,l,iq)+wresi(ij,l)*(qorig(ij,l)
    1128      :           -0.5*(1.+sigw)*dzqorig(ij,l))
    1129           ENDIF
    1130          ENDDO
    1131        ENDDO
    1132 c$OMP END DO NOWAIT   
    1133 
    1134 
    1135        ENDIF ! councfl=0
    1136 
    1137 
    1138 
    1139 c$OMP MASTER
    1140        DO ij=ijb,ije
    1141           wq(ij,llm+1,iq)=0.
    1142           wq(ij,1,iq)=0.
    1143        ENDDO
    1144 c$OMP END MASTER
    1145 c$OMP BARRIER
    1146 
    1147 ! CRisi: appel récursif de l'advection sur les fils.
    1148 ! Il faut faire ça avant d'avoir mis à jour q et masse
    1149 !     write(*,*)'vlsplt 942: iq,nqChildren(iq)=',iq,tracers(iq)%nqChildren
    1150       do ifils=1,tracers(iq)%nqDescen
    1151         iq2=tracers(iq)%iqDescen(ifils)
    1152 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1153         DO l=1,llm
    1154           DO ij=ijb,ije
    1155            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    1156             masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    1157             if (q(ij,l,iq).gt.min_qParent) then
    1158               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    1159             else
    1160               Ratio(ij,l,iq2)=min_ratio
    1161             endif
    1162             !wq(ij,l,iq2)=wq(ij,l,iq) ! correction bug le 15mai2015
    1163             w(ij,l,iq2)=wq(ij,l,iq)
    1164           enddo   
    1165         enddo
    1166 c$OMP END DO NOWAIT
    1167       enddo
    1168 c$OMP BARRIER
    1169 
    1170       do ifils=1,tracers(iq)%nqChildren
    1171         iq2=tracers(iq)%iqDescen(ifils)
    1172         call vlz_loc(Ratio,pente_max,masse,w,ijb_x,ije_x,iq2)
    1173       enddo
    1174 ! end CRisi 
    1175 
    1176 ! CRisi: On rajoute ici une barrière car on veut être sur que tous les
    1177 ! wq soient synchronisés
    1178 
    1179 c$OMP BARRIER
    1180 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    1181       DO l=1,llm
    1182          DO ij=ijb,ije
    1183             newmasse=masse(ij,l,iq)+w(ij,l+1,iq)-w(ij,l,iq)
    1184             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)
    1185      &         +wq(ij,l+1,iq)-wq(ij,l,iq))
    1186      &         /newmasse
    1187             masse(ij,l,iq)=newmasse
    1188          ENDDO
    1189       ENDDO
    1190 c$OMP END DO NOWAIT
    1191 
    1192      
    1193 ! retablir les fils en rapport de melange par rapport a l'air:
    1194       do ifils=1,tracers(iq)%nqDescen
    1195         iq2=tracers(iq)%iqDescen(ifils)
    1196 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
    1197         DO l=1,llm
    1198           DO ij=ijb,ije
    1199             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    1200           enddo
    1201         enddo
    1202 c$OMP END DO NOWAIT
    1203       enddo
    1204 
    1205       RETURN
    1206       END
    1207 c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
    1208 c
    1209 c      INCLUDE "dimensions.h"
    1210 c      INCLUDE "paramet.h"
    1211 
    1212 c      CHARACTER*(*) comment
    1213 c      real qmin,qmax
    1214 c      real zq(ip1jmp1,llm)
    1215 
    1216 c      INTEGER jadrs(ip1jmp1), jbad, k, i
    1217 
    1218 
    1219 c      DO k = 1, llm
    1220 c         jbad = 0
    1221 c         DO i = 1, ip1jmp1
    1222 c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
    1223 c            jbad = jbad + 1
    1224 c            jadrs(jbad) = i
    1225 c         ENDIF
    1226 c         ENDDO
    1227 c         IF (jbad.GT.0) THEN
    1228 c         PRINT*, comment
    1229 c         DO i = 1, jbad
    1230 cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
    1231 c         ENDDO
    1232 c         ENDIF
    1233 c      ENDDO
    1234 
    1235 c      return
    1236 c      end
    1237 
    1238 
    1239 
    1240 
     1201    enddo
     1202!$OMP END DO NOWAIT
     1203  enddo
     1204
     1205  RETURN
     1206END SUBROUTINE vlz_loc
     1207 ! SUBROUTINE minmaxq(zq,qmin,qmax,comment)
     1208!
     1209!  INCLUDE "dimensions.h"
     1210!  INCLUDE "paramet.h"
     1211
     1212!  CHARACTER*(*) comment
     1213!  real qmin,qmax
     1214!  real zq(ip1jmp1,llm)
     1215
     1216!  INTEGER jadrs(ip1jmp1), jbad, k, i
     1217
     1218
     1219!  DO k = 1, llm
     1220!     jbad = 0
     1221!     DO i = 1, ip1jmp1
     1222!     IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
     1223!        jbad = jbad + 1
     1224!        jadrs(jbad) = i
     1225!     ENDIF
     1226!     ENDDO
     1227!     IF (jbad.GT.0) THEN
     1228!     PRINT*, comment
     1229!     DO i = 1, jbad
     1230!c            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
     1231!     ENDDO
     1232!     ENDIF
     1233!  ENDDO
     1234
     1235!  return
     1236!  end
     1237
     1238
     1239
     1240
  • LMDZ6/trunk/libf/phylmd/cosp/MISR_simulator.f90

    r5247 r5248  
    1 ! 
     1!
    22! Copyright (c) 2009,  Roger Marchand, version 1.2
    33! All rights reserved.
    44! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
    55! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/MISR_simulator/MISR_simulator.f $
    6 ! 
    7 ! Redistribution and use in source and binary forms, with or without modification, are permitted 
     6!
     7! Redistribution and use in source and binary forms, with or without modification, are permitted
    88! provided that the following conditions are met:
    9 ! 
    10 !     * Redistributions of source code must retain the above copyright notice, this list of
    11 !       conditions and the following disclaimer.
    12 !     * Redistributions in binary form must reproduce the above copyright notice, this list
    13 !       of conditions and the following disclaimer in the documentation and/or other materials
    14 !       provided with the distribution.
    15 !     * Neither the name of the University of Washington nor the names of its contributors may be used
    16 !       to endorse or promote products derived from this software without specific prior written permission.
    17 ! 
     9!
     10! * Redistributions of source code must retain the above copyright notice, this list of
     11!   conditions and the following disclaimer.
     12! * Redistributions in binary form must reproduce the above copyright notice, this list
     13!   of conditions and the following disclaimer in the documentation and/or other materials
     14!   provided with the distribution.
     15! * Neither the name of the University of Washington nor the names of its contributors may be used
     16!   to endorse or promote products derived from this software without specific prior written permission.
     17!
    1818! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,
    19 ! BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT 
    20 ! SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
    21 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
    22 ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
     19! BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT
     20! SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
     21! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
     22! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
    2323! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    2424!
    2525
    26       SUBROUTINE MISR_simulator(
    27      &     npoints,
    28      &     nlev,
    29      &     ncol,
    30      &     sunlit,
    31      &     zfull,
    32      &     at,
    33      &     dtau_s,
    34      &     dtau_c,
    35      &     frac_out,
    36      &     missing_value,
    37      &     fq_MISR_TAU_v_CTH,
    38      &     dist_model_layertops,
    39      &     MISR_mean_ztop,
    40      &     MISR_cldarea
    41      & )
    42    
    43 
    44       implicit none
    45       integer n_MISR_CTH
    46       parameter(n_MISR_CTH=16)
    47          
    48 !     -----
    49 !     Input
    50 !     -----
    51 
    52       INTEGER npoints                   !  if ncol ==1, the number of model points in the horizontal grid 
    53                             !   else    the number of GCM grid points
    54                            
    55       INTEGER nlev                      !  number of model vertical levels
    56      
    57       INTEGER ncol                      !  number of model sub columns
    58                         !  (must already be generated in via scops and passed to this
    59                         !   routine via the variable frac_out )
    60  
    61       INTEGER sunlit(npoints)           !  1 for day points, 0 for night time
    62 
    63       REAL zfull(npoints,nlev)          !  height (in meters) of full model levels (i.e. midpoints)
    64                                         !  zfull(npoints,1)    is    top level of model
    65                                         !  zfull(npoints,nlev) is bottom level of model (closest point to surface) 
    66 
    67       REAL at(npoints,nlev)             !  temperature in each model level (K)
    68  
    69       REAL dtau_s(npoints,nlev)         !  visible wavelength cloud optical depth ... for "stratiform" condensate
    70                                         !  NOTE:  this the cloud optical depth of only the
    71                     !     the model cell (i,j)
    72                    
    73       REAL dtau_c(npoints,nlev)         !  visible wavelength cloud optical depth ... for "convective" condensate
    74                                         !  NOTE:  this the cloud optical depth of only the
    75                     !     the model cell (i,j)
    76                                      
    77       REAL frac_out(npoints,ncol,nlev)  !  NOTE: only need if columns>1 ... subgrid scheme in use.
    78      
    79       REAL missing_value
    80                                  
    81 !     ------
    82 !     Outputs
    83 !     ------
    84            
    85       REAL fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH)     
    86       REAL dist_model_layertops(npoints,n_MISR_CTH)
    87       REAL MISR_cldarea(npoints)               ! fractional area coverged by clouds
    88       REAL MISR_mean_ztop(npoints)             ! mean cloud top hieght(m) MISR would observe
    89                                    ! NOTE: == 0 if area ==0
    90                            
    91 
    92 !     ------
    93 !     Working variables
    94 !     ------
    95 
    96       REAL tau(npoints,ncol)        ! total column optical depth ...
    97 
    98       INTEGER j,ilev,ilev2,ibox,k
    99       INTEGER itau
    100          
    101       LOGICAL box_cloudy(npoints,ncol)
    102      
    103       real isccp_taumin
    104       real boxarea
    105       real tauchk
    106       REAL box_MISR_ztop(npoints,ncol)  ! cloud top hieght(m) MISR would observe
    107      
    108       integer thres_crossed_MISR
    109       integer loop,iMISR_ztop
    110      
    111       real dtau, cloud_dtau, MISR_penetration_height,ztest     
    112      
    113       real MISR_CTH_boundaries(n_MISR_CTH+1)
    114      
    115       DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3,
    116      c                    4, 5, 7, 9, 11, 13, 15, 17, 99 /
    117      
    118       DATA isccp_taumin / 0.3 /
    119    
    120       tauchk = -1.*log(0.9999999)
    121        
    122       !
    123       ! For each GCM cell or horizontal model grid point ...
    124       !
    125       do j=1,npoints   
    126 
    127          !
    128          !  estimate distribution of Model layer tops
    129          ! 
    130          dist_model_layertops(j,:)=0
    131 
    132        do ilev=1,nlev
    133            
    134         ! define location of "layer top"
    135         if(ilev.eq.1 .or. ilev.eq.nlev) then
    136             ztest=zfull(j,ilev)
     26SUBROUTINE MISR_simulator( &
     27        npoints, &
     28        nlev, &
     29        ncol, &
     30        sunlit, &
     31        zfull, &
     32        at, &
     33        dtau_s, &
     34        dtau_c, &
     35        frac_out, &
     36        missing_value, &
     37        fq_MISR_TAU_v_CTH, &
     38        dist_model_layertops, &
     39        MISR_mean_ztop, &
     40        MISR_cldarea &
     41        )
     42
     43
     44  implicit none
     45  integer :: n_MISR_CTH
     46  parameter(n_MISR_CTH=16)
     47
     48  ! -----
     49  ! Input
     50  ! -----
     51
     52  INTEGER :: npoints                   !  if ncol ==1, the number of model points in the horizontal grid
     53                        ! !   else    the number of GCM grid points
     54
     55  INTEGER :: nlev                      !  number of model vertical levels
     56
     57  INTEGER :: ncol                      !  number of model sub columns
     58                    ! !  (must already be generated in via scops and passed to this
     59                    ! !   routine via the variable frac_out )
     60
     61  INTEGER :: sunlit(npoints)           !  1 for day points, 0 for night time
     62
     63  REAL :: zfull(npoints,nlev)          !  height (in meters) of full model levels (i.e. midpoints)
     64                                    ! !  zfull(npoints,1)    is    top level of model
     65                                    ! !  zfull(npoints,nlev) is bottom level of model (closest point to surface)
     66
     67  REAL :: at(npoints,nlev)             !  temperature in each model level (K)
     68
     69  REAL :: dtau_s(npoints,nlev)         !  visible wavelength cloud optical depth ... for "stratiform" condensate
     70                                    ! !  NOTE:  this the cloud optical depth of only the
     71                ! !     the model cell (i,j)
     72
     73  REAL :: dtau_c(npoints,nlev)         !  visible wavelength cloud optical depth ... for "convective" condensate
     74                                    ! !  NOTE:  this the cloud optical depth of only the
     75                ! !     the model cell (i,j)
     76
     77  REAL :: frac_out(npoints,ncol,nlev)  !  NOTE: only need if columns>1 ... subgrid scheme in use.
     78
     79  REAL :: missing_value
     80
     81  ! ------
     82  ! Outputs
     83  ! ------
     84
     85  REAL :: fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH)
     86  REAL :: dist_model_layertops(npoints,n_MISR_CTH)
     87  REAL :: MISR_cldarea(npoints)               ! fractional area coverged by clouds
     88  REAL :: MISR_mean_ztop(npoints)             ! mean cloud top hieght(m) MISR would observe
     89                               ! ! NOTE: == 0 if area ==0
     90
     91
     92  ! ------
     93  ! Working variables
     94  ! ------
     95
     96  REAL :: tau(npoints,ncol)        ! total column optical depth ...
     97
     98  INTEGER :: j,ilev,ilev2,ibox,k
     99  INTEGER :: itau
     100
     101  LOGICAL :: box_cloudy(npoints,ncol)
     102
     103  real :: isccp_taumin
     104  real :: boxarea
     105  real :: tauchk
     106  REAL :: box_MISR_ztop(npoints,ncol)  ! cloud top hieght(m) MISR would observe
     107
     108  integer :: thres_crossed_MISR
     109  integer :: loop,iMISR_ztop
     110
     111  real :: dtau, cloud_dtau, MISR_penetration_height,ztest
     112
     113  real :: MISR_CTH_boundaries(n_MISR_CTH+1)
     114
     115  DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3, &
     116        4, 5, 7, 9, 11, 13, 15, 17, 99 /
     117
     118  DATA isccp_taumin / 0.3 /
     119
     120  tauchk = -1.*log(0.9999999)
     121
     122  ! !
     123  ! ! For each GCM cell or horizontal model grid point ...
     124  ! !
     125  do j=1,npoints
     126
     127     ! !
     128     ! !  estimate distribution of Model layer tops
     129     ! !
     130     dist_model_layertops(j,:)=0
     131
     132   do ilev=1,nlev
     133
     134    ! ! define location of "layer top"
     135    if(ilev.eq.1 .or. ilev.eq.nlev) then
     136        ztest=zfull(j,ilev)
     137    else
     138        ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1))
     139    endif
     140
     141    ! ! find MISR layer that contains this level
     142    ! ! note, the first MISR level is "no height" level
     143    iMISR_ztop=2
     144    do loop=2,n_MISR_CTH
     145
     146        if ( ztest .gt. &
     147              1000*MISR_CTH_boundaries(loop+1) ) then
     148
     149            iMISR_ztop=loop+1
     150        endif
     151    enddo
     152
     153    dist_model_layertops(j,iMISR_ztop)= &
     154          dist_model_layertops(j,iMISR_ztop)+1
     155   enddo
     156
     157
     158     ! !
     159     ! ! compute total cloud optical depth for each column
     160     ! !
     161   do ibox=1,ncol
     162
     163    ! ! Initialize tau to zero in each subcolum
     164        tau(j,ibox)=0.
     165    box_cloudy(j,ibox)=.false.
     166    box_MISR_ztop(j,ibox)=0
     167
     168    ! ! initialize threshold detection for each sub column
     169    thres_crossed_MISR=0;
     170
     171    do ilev=1,nlev
     172
     173         dtau=0
     174
     175         if (frac_out(j,ibox,ilev).eq.1) then
     176                    dtau = dtau_s(j,ilev)
     177             endif
     178
     179             if (frac_out(j,ibox,ilev).eq.2) then
     180                    dtau = dtau_c(j,ilev)
     181             end if
     182
     183         tau(j,ibox)=tau(j,ibox)+ dtau
     184
     185
     186    ! ! NOW for MISR ..
     187    ! ! if there a cloud ... start the counter ... store this height
     188    if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then
     189
     190        ! ! first encountered a "cloud"
     191        thres_crossed_MISR=1
     192        cloud_dtau=0
     193    endif
     194
     195    if( thres_crossed_MISR .lt. 99 .and. &
     196          thres_crossed_MISR .gt. 0 ) then
     197
     198            if( dtau .eq. 0.) then
     199
     200                ! ! we have come to the end of the current cloud
     201            ! ! layer without yet selecting a CTH boundary.
     202            ! ! ... restart cloud tau counter
     203            cloud_dtau=0
    137204        else
    138             ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1))
    139         endif   
    140 
    141         ! find MISR layer that contains this level
    142         ! note, the first MISR level is "no height" level
     205            ! ! add current optical depth to count for
     206            ! ! the current cloud layer
     207            cloud_dtau=cloud_dtau+dtau
     208        endif
     209
     210        ! ! if the cloud is continuous but optically thin (< 1)
     211        ! ! from above the current layer cloud top to the current level
     212        ! ! then MISR will like see a top below the top of the current
     213        ! ! layer
     214        if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then
     215
     216            if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
     217
     218                ! ! MISR will likely penetrate to some point
     219                ! ! within this layer ... the middle
     220                MISR_penetration_height=zfull(j,ilev)
     221
     222            else
     223                ! ! take the OD = 1.0 level into this layer
     224                MISR_penetration_height= &
     225                      0.5*(zfull(j,ilev)+zfull(j,ilev-1)) - &
     226                      0.5*(zfull(j,ilev-1)-zfull(j,ilev+1)) &
     227                      /dtau
     228            endif
     229
     230            box_MISR_ztop(j,ibox)=MISR_penetration_height
     231
     232        endif
     233
     234        ! ! check for a distinctive water layer
     235        if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then
     236
     237                ! ! must be a water cloud ...
     238            ! ! take this as CTH level
     239            thres_crossed_MISR=99
     240        endif
     241
     242        ! ! if the total column optical depth is "large" than
     243        ! ! MISR can't seen anything else ... set current point as CTH level
     244        if(tau(j,ibox) .gt. 5) then
     245
     246            thres_crossed_MISR=99
     247        endif
     248
     249    endif ! MISR CTH booundary not set
     250
     251    enddo  !ilev - loop over vertical levesl
     252
     253    ! ! written by roj 5/2006
     254    ! ! check to see if there was a cloud for which we didn't
     255    ! ! set a MISR cloud top boundary
     256    if( thres_crossed_MISR .eq. 1) then
     257
     258    ! ! if the cloud has a total optical depth of greater
     259    ! ! than ~ 0.5 MISR will still likely pick up this cloud
     260    ! ! with a height near the true cloud top
     261    ! ! otherwise there should be no CTH
     262    if( tau(j,ibox) .gt. 0.5) then
     263
     264        ! ! keep MISR detected CTH
     265
     266    elseif(tau(j,ibox) .gt. 0.2) then
     267
     268        ! ! MISR may detect but wont likley have a good height
     269        box_MISR_ztop(j,ibox)=-1
     270
     271    else
     272        ! ! MISR not likely to even detect.
     273        ! ! so set as not cloudy
     274        box_MISR_ztop(j,ibox)=0
     275
     276    endif
     277
     278    endif
     279
     280   enddo  ! loop of subcolumns
     281   enddo    ! loop of gridpoints
     282
     283
     284    ! !
     285    ! !   Modify MISR CTH for satellite spatial / pattern matcher effects
     286  !   !
     287  !   !   Code in this region added by roj 5/2006 to account
     288  !   !   for spatial effect of the MISR pattern matcher.
     289  !   !   Basically, if a column is found between two neighbors
     290  !   !   at the same CTH, and that column has no hieght or
     291  !   !   a lower CTH, THEN misr will tend to but place the
     292  !   !   odd column at the same height as it neighbors.
     293  !   !
     294  !   !   This setup assumes the columns represent a about a 1 to 4 km scale
     295  !   !   it will need to be modified significantly, otherwise
     296    if(ncol.eq.1) then
     297
     298   ! ! adjust based on neightboring points ... i.e. only 2D grid was input
     299       do j=2,npoints-1
     300
     301        if(box_MISR_ztop(j-1,1).gt.0 .and. &
     302              box_MISR_ztop(j+1,1).gt.0       ) then
     303
     304            if( abs( box_MISR_ztop(j-1,1) - &
     305                  box_MISR_ztop(j+1,1) ) .lt. 500 &
     306                  .and. &
     307                  box_MISR_ztop(j,1) .lt. &
     308                  box_MISR_ztop(j+1,1)     ) then
     309
     310                box_MISR_ztop(j,1) = &
     311                      box_MISR_ztop(j+1,1)
     312            endif
     313
     314        endif
     315     enddo
     316    else
     317
     318     ! ! adjust based on neighboring subcolumns ....
     319     do ibox=2,ncol-1
     320
     321        if(box_MISR_ztop(1,ibox-1).gt.0 .and. &
     322              box_MISR_ztop(1,ibox+1).gt.0        ) then
     323
     324            if( abs( box_MISR_ztop(1,ibox-1) - &
     325                  box_MISR_ztop(1,ibox+1) ) .lt. 500 &
     326                  .and. &
     327                  box_MISR_ztop(1,ibox) .lt. &
     328                  box_MISR_ztop(1,ibox+1)     ) then
     329
     330                box_MISR_ztop(1,ibox) = &
     331                      box_MISR_ztop(1,ibox+1)
     332            endif
     333
     334        endif
     335     enddo
     336
     337    endif
     338
     339    ! !
     340  !   !     DETERMINE CLOUD TYPE FREQUENCIES
     341  !   !
     342  !   !     Now that ztop and tau have been determined,
     343  !   !     determine amount of each cloud type
     344    boxarea=1./real(ncol)
     345    do j=1,npoints
     346
     347     ! ! reset frequencies -- modified loop structure, roj 5/2006
     348     do ilev=1,7  ! "tau loop"
     349        do  ilev2=1,n_MISR_CTH
     350        fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0.
     351        enddo
     352     enddo
     353
     354     MISR_cldarea(j)=0.
     355     MISR_mean_ztop(j)=0.
     356
     357     do ibox=1,ncol
     358
     359        if (tau(j,ibox) .gt. (tauchk)) then
     360           box_cloudy(j,ibox)=.true.
     361        endif
     362
     363        itau = 0
     364
     365        if (box_cloudy(j,ibox)) then
     366
     367      ! !determine optical depth category
     368          if (tau(j,ibox) .lt. isccp_taumin) then
     369              itau=1
     370          else if (tau(j,ibox) .ge. isccp_taumin &
     371                .and. tau(j,ibox) .lt. 1.3) then
     372              itau=2
     373          else if (tau(j,ibox) .ge. 1.3 &
     374                .and. tau(j,ibox) .lt. 3.6) then
     375              itau=3
     376          else if (tau(j,ibox) .ge. 3.6 &
     377                .and. tau(j,ibox) .lt. 9.4) then
     378              itau=4
     379          else if (tau(j,ibox) .ge. 9.4 &
     380                .and. tau(j,ibox) .lt. 23.) then
     381              itau=5
     382          else if (tau(j,ibox) .ge. 23. &
     383                .and. tau(j,ibox) .lt. 60.) then
     384              itau=6
     385          else if (tau(j,ibox) .ge. 60.) then
     386              itau=7
     387          endif
     388
     389         endif
     390
     391   ! ! update MISR histograms and summary metrics - roj 5/2005
     392   if (sunlit(j).eq.1) then
     393
     394          ! !if cloudy added by roj 5/2005
     395      if( box_MISR_ztop(j,ibox).eq.0) then
     396
     397        ! ! no cloud detected
     398        iMISR_ztop=0
     399
     400      elseif( box_MISR_ztop(j,ibox).eq.-1) then
     401
     402        ! ! cloud can be detected but too thin to get CTH
     403        iMISR_ztop=1
     404
     405        fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= &
     406              fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
     407
     408      else
     409
     410        ! !
     411        ! ! determine index for MISR bin set
     412        ! !
     413
    143414        iMISR_ztop=2
     415
    144416        do loop=2,n_MISR_CTH
    145        
    146             if ( ztest .gt.
    147      &                1000*MISR_CTH_boundaries(loop+1) ) then
    148        
    149                 iMISR_ztop=loop+1
     417
     418            if ( box_MISR_ztop(j,ibox) .gt. &
     419                  1000*MISR_CTH_boundaries(loop+1) ) then
     420
     421              iMISR_ztop=loop+1
     422
    150423            endif
    151424        enddo
    152425
    153         dist_model_layertops(j,iMISR_ztop)=
    154      &          dist_model_layertops(j,iMISR_ztop)+1
    155        enddo
    156    
    157    
    158          !
    159          ! compute total cloud optical depth for each column
    160          !       
    161        do ibox=1,ncol     
    162        
    163         ! Initialize tau to zero in each subcolum
    164             tau(j,ibox)=0.
    165         box_cloudy(j,ibox)=.false.
    166         box_MISR_ztop(j,ibox)=0 
    167        
    168         ! initialize threshold detection for each sub column
    169         thres_crossed_MISR=0;
    170        
    171         do ilev=1,nlev
    172      
    173              dtau=0
    174              
    175              if (frac_out(j,ibox,ilev).eq.1) then
    176                         dtau = dtau_s(j,ilev)
    177                  endif
    178                  
    179                  if (frac_out(j,ibox,ilev).eq.2) then
    180                         dtau = dtau_c(j,ilev)
    181                  end if
    182                  
    183              tau(j,ibox)=tau(j,ibox)+ dtau
    184              
    185                      
    186         ! NOW for MISR ..
    187         ! if there a cloud ... start the counter ... store this height
    188         if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then
    189        
    190             ! first encountered a "cloud"
    191             thres_crossed_MISR=1 
    192             cloud_dtau=0           
    193         endif   
    194                
    195         if( thres_crossed_MISR .lt. 99 .and.
    196      &              thres_crossed_MISR .gt. 0 ) then
    197      
    198                 if( dtau .eq. 0.) then
    199        
    200                     ! we have come to the end of the current cloud
    201                 ! layer without yet selecting a CTH boundary.
    202                 ! ... restart cloud tau counter
    203                 cloud_dtau=0
    204             else
    205                 ! add current optical depth to count for
    206                 ! the current cloud layer
    207                 cloud_dtau=cloud_dtau+dtau
    208             endif
    209                
    210             ! if the cloud is continuous but optically thin (< 1)
    211             ! from above the current layer cloud top to the current level
    212             ! then MISR will like see a top below the top of the current
    213             ! layer
    214             if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then
    215            
    216                 if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
    217 
    218                     ! MISR will likely penetrate to some point
    219                     ! within this layer ... the middle
    220                     MISR_penetration_height=zfull(j,ilev)
    221 
    222                 else
    223                     ! take the OD = 1.0 level into this layer
    224                     MISR_penetration_height=
    225      &                     0.5*(zfull(j,ilev)+zfull(j,ilev-1)) -
    226      &                     0.5*(zfull(j,ilev-1)-zfull(j,ilev+1))
    227      &                  /dtau
    228                 endif   
    229 
    230                 box_MISR_ztop(j,ibox)=MISR_penetration_height
    231                
    232             endif
    233        
    234             ! check for a distinctive water layer
    235             if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then
    236      
    237                     ! must be a water cloud ...
    238                 ! take this as CTH level
    239                 thres_crossed_MISR=99
    240             endif
    241        
    242             ! if the total column optical depth is "large" than
    243             ! MISR can't seen anything else ... set current point as CTH level
    244             if(tau(j,ibox) .gt. 5) then
    245 
    246                 thres_crossed_MISR=99           
    247             endif
    248 
    249         endif ! MISR CTH booundary not set
    250        
    251         enddo  !ilev - loop over vertical levesl
    252    
    253         ! written by roj 5/2006
    254         ! check to see if there was a cloud for which we didn't
    255         ! set a MISR cloud top boundary
    256         if( thres_crossed_MISR .eq. 1) then
    257    
    258         ! if the cloud has a total optical depth of greater
    259         ! than ~ 0.5 MISR will still likely pick up this cloud
    260         ! with a height near the true cloud top
    261         ! otherwise there should be no CTH
    262         if( tau(j,ibox) .gt. 0.5) then
    263 
    264             ! keep MISR detected CTH
    265            
    266         elseif(tau(j,ibox) .gt. 0.2) then
    267 
    268             ! MISR may detect but wont likley have a good height
    269             box_MISR_ztop(j,ibox)=-1
    270            
     426        if(box_cloudy(j,ibox)) then
     427
     428           ! ! there is an isccp clouds so itau(j) is defined
     429           fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= &
     430                 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
     431
    271432        else
    272             ! MISR not likely to even detect.
    273             ! so set as not cloudy
    274             box_MISR_ztop(j,ibox)=0
    275 
    276         endif
    277                        
    278         endif
    279    
    280        enddo  ! loop of subcolumns
    281        enddo    ! loop of gridpoints
    282        
    283 
    284         !     
    285         !   Modify MISR CTH for satellite spatial / pattern matcher effects
    286     !
    287     !   Code in this region added by roj 5/2006 to account
    288     !   for spatial effect of the MISR pattern matcher.
    289     !   Basically, if a column is found between two neighbors
    290     !   at the same CTH, and that column has no hieght or
    291     !   a lower CTH, THEN misr will tend to but place the
    292     !   odd column at the same height as it neighbors.
    293     !
    294     !   This setup assumes the columns represent a about a 1 to 4 km scale
    295     !   it will need to be modified significantly, otherwise
    296         if(ncol.eq.1) then
    297    
    298        ! adjust based on neightboring points ... i.e. only 2D grid was input
    299            do j=2,npoints-1
    300            
    301             if(box_MISR_ztop(j-1,1).gt.0 .and.
    302      &             box_MISR_ztop(j+1,1).gt.0       ) then
    303 
    304                 if( abs( box_MISR_ztop(j-1,1) - 
    305      &                   box_MISR_ztop(j+1,1) ) .lt. 500
    306      &              .and.
    307      &                   box_MISR_ztop(j,1) .lt.
    308      &                   box_MISR_ztop(j+1,1)     ) then
    309            
    310                     box_MISR_ztop(j,1) =
    311      &                      box_MISR_ztop(j+1,1)   
    312                 endif
    313 
    314             endif
     433            ! ! MISR CTH resolution is trying to fill in a
     434            ! ! broken cloud scene where there is no condensate.
     435            ! ! The MISR CTH-1D-OD product will only put in a cloud
     436            ! ! if the MISR cloud mask indicates cloud.
     437            ! ! therefore we will not include this column in the histogram
     438            ! ! in reality aerosoal and 3D effects or bright surfaces
     439            ! ! could fool the MISR cloud mask
     440
     441            ! ! the alternative is to count as very thin cloud ??
     442            ! fq_MISR_TAU_v_CTH(1,iMISR_ztop)=
     443  ! &                     fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea
     444        endif
     445
     446
     447        MISR_mean_ztop(j)=MISR_mean_ztop(j)+ &
     448              box_MISR_ztop(j,ibox)*boxarea
     449
     450        MISR_cldarea(j)=MISR_cldarea(j) + boxarea
     451
     452      endif
     453   else
     454      ! ! Set to issing data. A. Bodas - 14/05/2010
     455      do loop=1,n_MISR_CTH
     456         do k=1,7
     457            fq_MISR_TAU_v_CTH(j,k,loop) = missing_value
    315458         enddo
    316         else
    317          
    318          ! adjust based on neighboring subcolumns ....
    319          do ibox=2,ncol-1
    320            
    321             if(box_MISR_ztop(1,ibox-1).gt.0 .and.
    322      &             box_MISR_ztop(1,ibox+1).gt.0        ) then
    323 
    324                 if( abs( box_MISR_ztop(1,ibox-1) - 
    325      &                   box_MISR_ztop(1,ibox+1) ) .lt. 500
    326      &              .and.
    327      &                   box_MISR_ztop(1,ibox) .lt.
    328      &                   box_MISR_ztop(1,ibox+1)     ) then
    329            
    330                     box_MISR_ztop(1,ibox) =
    331      &                      box_MISR_ztop(1,ibox+1)   
    332                 endif
    333 
    334             endif
    335          enddo
    336      
    337         endif
    338 
    339         !     
    340     !     DETERMINE CLOUD TYPE FREQUENCIES
    341     !
    342     !     Now that ztop and tau have been determined,
    343     !     determine amount of each cloud type
    344         boxarea=1./real(ncol) 
    345         do j=1,npoints
    346 
    347          ! reset frequencies -- modified loop structure, roj 5/2006
    348          do ilev=1,7  ! "tau loop" 
    349             do  ilev2=1,n_MISR_CTH                     
    350             fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0.     
    351             enddo
    352          enddo
    353            
    354          MISR_cldarea(j)=0.
    355          MISR_mean_ztop(j)=0.
    356 
    357          do ibox=1,ncol
    358 
    359             if (tau(j,ibox) .gt. (tauchk)) then
    360                box_cloudy(j,ibox)=.true.
    361             endif
    362  
    363             itau = 0
    364        
    365             if (box_cloudy(j,ibox)) then
    366    
    367           !determine optical depth category
    368               if (tau(j,ibox) .lt. isccp_taumin) then
    369                   itau=1
    370               else if (tau(j,ibox) .ge. isccp_taumin                                   
    371      &          .and. tau(j,ibox) .lt. 1.3) then
    372                   itau=2
    373               else if (tau(j,ibox) .ge. 1.3
    374      &          .and. tau(j,ibox) .lt. 3.6) then
    375                   itau=3
    376               else if (tau(j,ibox) .ge. 3.6
    377      &          .and. tau(j,ibox) .lt. 9.4) then
    378                   itau=4
    379               else if (tau(j,ibox) .ge. 9.4
    380      &          .and. tau(j,ibox) .lt. 23.) then
    381                   itau=5
    382               else if (tau(j,ibox) .ge. 23.
    383      &          .and. tau(j,ibox) .lt. 60.) then
    384                   itau=6
    385               else if (tau(j,ibox) .ge. 60.) then
    386                   itau=7
    387               endif
    388              
    389              endif 
    390 
    391        ! update MISR histograms and summary metrics - roj 5/2005
    392        if (sunlit(j).eq.1) then
    393                      
    394               !if cloudy added by roj 5/2005
    395           if( box_MISR_ztop(j,ibox).eq.0) then
    396          
    397             ! no cloud detected
    398             iMISR_ztop=0
    399 
    400           elseif( box_MISR_ztop(j,ibox).eq.-1) then
    401 
    402             ! cloud can be detected but too thin to get CTH
    403             iMISR_ztop=1   
    404 
    405             fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
    406      &            fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
    407 
    408           else
    409            
    410             !
    411             ! determine index for MISR bin set
    412             !
    413 
    414             iMISR_ztop=2
    415            
    416             do loop=2,n_MISR_CTH
    417        
    418                 if ( box_MISR_ztop(j,ibox) .gt.
    419      &                1000*MISR_CTH_boundaries(loop+1) ) then
    420        
    421                   iMISR_ztop=loop+1
    422 
    423                 endif
    424             enddo
    425          
    426             if(box_cloudy(j,ibox)) then
    427            
    428                ! there is an isccp clouds so itau(j) is defined
    429                fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
    430      &            fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
    431      
    432             else
    433                 ! MISR CTH resolution is trying to fill in a
    434                 ! broken cloud scene where there is no condensate.
    435                 ! The MISR CTH-1D-OD product will only put in a cloud
    436                 ! if the MISR cloud mask indicates cloud.
    437                 ! therefore we will not include this column in the histogram
    438                 ! in reality aerosoal and 3D effects or bright surfaces
    439                 ! could fool the MISR cloud mask
    440 
    441                 ! the alternative is to count as very thin cloud ??
    442 !               fq_MISR_TAU_v_CTH(1,iMISR_ztop)=
    443 !     &                     fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea
    444             endif
    445 
    446 
    447             MISR_mean_ztop(j)=MISR_mean_ztop(j)+
    448      &                       box_MISR_ztop(j,ibox)*boxarea         
    449 
    450             MISR_cldarea(j)=MISR_cldarea(j) + boxarea
    451  
    452           endif
    453        else
    454           ! Set to issing data. A. Bodas - 14/05/2010
    455           do loop=1,n_MISR_CTH
    456              do k=1,7
    457                 fq_MISR_TAU_v_CTH(j,k,loop) = missing_value
    458              enddo
    459              dist_model_layertops(j,loop) = missing_value
    460           enddo
    461           MISR_cldarea(j) = missing_value
    462           MISR_mean_ztop(npoints) = missing_value
    463 
    464        endif ! is sunlight ?
    465        
    466        enddo ! ibox - loop over subcolumns         
    467      
    468        if( MISR_cldarea(j) .gt. 0.) then
    469         MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j)   ! roj 5/2006
    470        endif
    471 
    472        enddo  ! loop over grid points
    473 
    474       return
    475       end
     459         dist_model_layertops(j,loop) = missing_value
     460      enddo
     461      MISR_cldarea(j) = missing_value
     462      MISR_mean_ztop(npoints) = missing_value
     463
     464   endif ! is sunlight ?
     465
     466   enddo ! ibox - loop over subcolumns
     467
     468   if( MISR_cldarea(j) .gt. 0.) then
     469    MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j)   ! roj 5/2006
     470   endif
     471
     472   enddo  ! loop over grid points
     473
     474  return
     475end subroutine misr_simulator
  • LMDZ6/trunk/libf/phylmd/cosp/icarus.f90

    r5247 r5248  
    11! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
    22! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/icarus.f $
    3       SUBROUTINE ICARUS(
    4      &     debug,
    5      &     debugcol,
    6      &     npoints,
    7      &     sunlit,
    8      &     nlev,
    9      &     ncol,
    10      &     pfull,
    11      &     phalf,
    12      &     qv,
    13      &     cc,
    14      &     conv,
    15      &     dtau_s,
    16      &     dtau_c,
    17      &     top_height,
    18      &     top_height_direction,
    19      &     overlap,
    20      &     frac_out,
    21      &     skt,
    22      &     emsfc_lw,
    23      &     at,
    24      &     dem_s,
    25      &     dem_c,
    26      &     fq_isccp,
    27      &     totalcldarea,
    28      &     meanptop,
    29      &     meantaucld,
    30      &     meanalbedocld,
    31      &     meantb,
    32      &     meantbclr,
    33      &     boxtau,
    34      &     boxptop
    35      &)
    36 
    37 !$Id: icarus.f,v 4.1 2010/05/27 16:30:18 hadmw Exp $
    38 
    39 ! *****************************COPYRIGHT****************************
    40 ! (c) 2009, Lawrence Livermore National Security Limited Liability
    41 ! Corporation.
    42 ! All rights reserved.
    43 !
    44 ! Redistribution and use in source and binary forms, with or without
    45 ! modification, are permitted provided that the
    46 ! following conditions are met:
    47 !
    48 !     * Redistributions of source code must retain the above
    49 !       copyright  notice, this list of conditions and the following
    50 !       disclaimer.
    51 !     * Redistributions in binary form must reproduce the above
    52 !       copyright notice, this list of conditions and the following
    53 !       disclaimer in the documentation and/or other materials
    54 !       provided with the distribution.
    55 !     * Neither the name of the Lawrence Livermore National Security
    56 !       Limited Liability Corporation nor the names of its
    57 !       contributors may be used to endorse or promote products
    58 !       derived from this software without specific prior written
    59 !       permission.
    60 !
    61 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    62 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    63 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
    64 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
    65 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    66 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
    67 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
    68 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
    69 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
    70 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
    71 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 
    72 !
    73 ! *****************************COPYRIGHT*******************************
    74 ! *****************************COPYRIGHT*******************************
    75 ! *****************************COPYRIGHT*******************************
    76 ! *****************************COPYRIGHT*******************************
    77 
    78       implicit none
    79 
    80 !     NOTE:   the maximum number of levels and columns is set by
    81 !             the following parameter statement
    82 
    83       INTEGER ncolprint
    84      
    85 !     -----
    86 !     Input
    87 !     -----
    88 
    89       INTEGER npoints       !  number of model points in the horizontal
    90       INTEGER nlev          !  number of model levels in column
    91       INTEGER ncol          !  number of subcolumns
    92 
    93       INTEGER sunlit(npoints) !  1 for day points, 0 for night time
    94 
    95       REAL pfull(npoints,nlev)
    96                        !  pressure of full model levels (Pascals)
    97                   !  pfull(npoints,1) is top level of model
    98                   !  pfull(npoints,nlev) is bot of model
    99 
    100       REAL phalf(npoints,nlev+1)
    101                   !  pressure of half model levels (Pascals)
    102                   !  phalf(npoints,1) is top of model
    103                   !  phalf(npoints,nlev+1) is the surface pressure
    104 
    105       REAL qv(npoints,nlev)
    106                   !  water vapor specific humidity (kg vapor/ kg air)
    107                   !         on full model levels
    108 
    109       REAL cc(npoints,nlev)   
    110                   !  input cloud cover in each model level (fraction)
    111                   !  NOTE:  This is the HORIZONTAL area of each
    112                   !         grid box covered by clouds
    113 
    114       REAL conv(npoints,nlev)
    115                   !  input convective cloud cover in each model
    116                   !   level (fraction)
    117                   !  NOTE:  This is the HORIZONTAL area of each
    118                   !         grid box covered by convective clouds
    119 
    120       REAL dtau_s(npoints,nlev)
    121                   !  mean 0.67 micron optical depth of stratiform
    122                 !  clouds in each model level
    123                   !  NOTE:  this the cloud optical depth of only the
    124                   !  cloudy part of the grid box, it is not weighted
    125                   !  with the 0 cloud optical depth of the clear
    126                   !         part of the grid box
    127 
    128       REAL dtau_c(npoints,nlev)
    129                   !  mean 0.67 micron optical depth of convective
    130                 !  clouds in each
    131                   !  model level.  Same note applies as in dtau_s.
    132 
    133       INTEGER overlap                   !  overlap type
    134                               !  1=max
    135                               !  2=rand
    136                               !  3=max/rand
    137 
    138       INTEGER top_height                !  1 = adjust top height using both a computed
    139                                         !  infrared brightness temperature and the visible
    140                               !  optical depth to adjust cloud top pressure. Note
    141                               !  that this calculation is most appropriate to compare
    142                               !  to ISCCP data during sunlit hours.
    143                                         !  2 = do not adjust top height, that is cloud top
    144                                         !  pressure is the actual cloud top pressure
    145                                         !  in the model
    146                               !  3 = adjust top height using only the computed
    147                               !  infrared brightness temperature. Note that this
    148                               !  calculation is most appropriate to compare to ISCCP
    149                               !  IR only algortihm (i.e. you can compare to nighttime
    150                               !  ISCCP data with this option)
    151 
    152       INTEGER top_height_direction ! direction for finding atmosphere pressure level
    153                                  ! with interpolated temperature equal to the radiance
    154                                  ! determined cloud-top temperature
    155                                  !
    156                                  ! 1 = find the *lowest* altitude (highest pressure) level
    157                                  ! with interpolated temperature equal to the radiance
    158                                  ! determined cloud-top temperature
    159                                  !
    160                                  ! 2 = find the *highest* altitude (lowest pressure) level
    161                                  ! with interpolated temperature equal to the radiance
    162                                  ! determined cloud-top temperature
    163                                  !
    164                                  ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
    165                                  !                               !
    166                                  ! 1 = old setting: matches all versions of
    167                                  ! ISCCP simulator with versions numbers 3.5.1 and lower
    168                                  !
    169                                  ! 2 = default setting: for version numbers 4.0 and higher
    170 !
    171 !     The following input variables are used only if top_height = 1 or top_height = 3
    172 !
    173       REAL skt(npoints)                 !  skin Temperature (K)
    174       REAL emsfc_lw                     !  10.5 micron emissivity of surface (fraction)                                           
    175       REAL at(npoints,nlev)                   !  temperature in each model level (K)
    176       REAL dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
    177                               !  clouds in each
    178                                         !  model level.  Same note applies as in dtau_s.
    179       REAL dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
    180                               !  clouds in each
    181                                         !  model level.  Same note applies as in dtau_s.
    182 
    183       REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
    184                               ! Equivalent of BOX in original version, but
    185                               ! indexed by column then row, rather than
    186                               ! by row then column
    187 
    188 
    189 
    190 !     ------
    191 !     Output
    192 !     ------
    193 
    194       REAL fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
    195                                         !  each of the 49 ISCCP D level cloud types
    196 
    197       REAL totalcldarea(npoints)        !  the fraction of model grid box columns
    198                                         !  with cloud somewhere in them.  NOTE: This diagnostic
    199                                         ! does not count model clouds with tau < isccp_taumin
    200                               ! Thus this diagnostic does not equal the sum over all entries of fq_isccp.
    201                               ! However, this diagnostic does equal the sum over entries of fq_isccp with
    202                               ! itau = 2:7 (omitting itau = 1)
    203      
    204      
    205       ! The following three means are averages only over the cloudy areas with tau > isccp_taumin. 
    206       ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero.     
    207                              
    208       REAL meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
    209                                         !  in cloud top pressure.
    210                              
    211       REAL meantaucld(npoints)          !  mean optical thickness
    212                                         !  linear averaging in albedo performed.
    213      
    214       real meanalbedocld(npoints)        ! mean cloud albedo
    215                                         ! linear averaging in albedo performed
    216                                        
    217       real meantb(npoints)              ! mean all-sky 10.5 micron brightness temperature
    218      
    219       real meantbclr(npoints)           ! mean clear-sky 10.5 micron brightness temperature
    220      
    221       REAL boxtau(npoints,ncol)         !  optical thickness in each column
    222      
    223       REAL boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column
    224                              
    225                                                                                          
    226 !
    227 !     ------
    228 !     Working variables added when program updated to mimic Mark Webb's PV-Wave code
    229 !     ------
    230 
    231       REAL dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave
    232                               !  emissivity in part of
    233                               !  gridbox under consideration
    234 
    235       REAL ptrop(npoints)
    236       REAL attrop(npoints)
    237       REAL attropmin (npoints)
    238       REAL atmax(npoints)
    239       REAL btcmin(npoints)
    240       REAL transmax(npoints)
    241 
    242       INTEGER i,j,ilev,ibox,itrop(npoints)
    243       INTEGER ipres(npoints)
    244       INTEGER itau(npoints),ilev2
    245       INTEGER acc(nlev,ncol)
    246       INTEGER match(npoints,nlev-1)
    247       INTEGER nmatch(npoints)
    248       INTEGER levmatch(npoints,ncol)
    249      
    250       !variables needed for water vapor continuum absorption
    251       real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
    252       real taumin(npoints)
    253       real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
    254       real press(npoints), dpress(npoints), atmden(npoints)
    255       real rvh20(npoints), wk(npoints), rhoave(npoints)
    256       real rh20s(npoints), rfrgn(npoints)
    257       real tmpexp(npoints),tauwv(npoints)
    258      
    259       character*1 cchar(6),cchar_realtops(6)
    260       integer icycle
    261       REAL tau(npoints,ncol)
    262       LOGICAL box_cloudy(npoints,ncol)
    263       REAL tb(npoints,ncol)
    264       REAL ptop(npoints,ncol)
    265       REAL emcld(npoints,ncol)
    266       REAL fluxtop(npoints,ncol)
    267       REAL trans_layers_above(npoints,ncol)
    268       real isccp_taumin,fluxtopinit(npoints),tauir(npoints)
    269       REAL albedocld(npoints,ncol)
    270       real boxarea
    271       integer debug       ! set to non-zero value to print out inputs
    272                     ! with step debug
    273       integer debugcol    ! set to non-zero value to print out column
    274                     ! decomposition with step debugcol
    275       integer rangevec(npoints),rangeerror
    276 
    277       integer index1(npoints),num1,jj,k1,k2
    278       real rec2p13,tauchk,logp,logp1,logp2,atd
    279       real output_missing_value
    280 
    281       character*10 ftn09
    282      
    283       DATA isccp_taumin / 0.3 /
    284       DATA output_missing_value / -1.E+30 /
    285       DATA cchar / ' ','-','1','+','I','+'/
    286       DATA cchar_realtops / ' ',' ','1','1','I','I'/
    287 
    288 !     ------ End duplicate definitions common to wrapper routine
    289 
    290       tauchk = -1.*log(0.9999999)
    291       rec2p13=1./2.13
    292 
    293       ncolprint=0
    294 
    295       if ( debug.ne.0 ) then
    296           j=1
     3SUBROUTINE ICARUS( &
     4        debug, &
     5        debugcol, &
     6        npoints, &
     7        sunlit, &
     8        nlev, &
     9        ncol, &
     10        pfull, &
     11        phalf, &
     12        qv, &
     13        cc, &
     14        conv, &
     15        dtau_s, &
     16        dtau_c, &
     17        top_height, &
     18        top_height_direction, &
     19        overlap, &
     20        frac_out, &
     21        skt, &
     22        emsfc_lw, &
     23        at, &
     24        dem_s, &
     25        dem_c, &
     26        fq_isccp, &
     27        totalcldarea, &
     28        meanptop, &
     29        meantaucld, &
     30        meanalbedocld, &
     31        meantb, &
     32        meantbclr, &
     33        boxtau, &
     34        boxptop &
     35        )
     36
     37  !$Id: icarus.f,v 4.1 2010/05/27 16:30:18 hadmw Exp $
     38
     39  ! *****************************COPYRIGHT****************************
     40  ! (c) 2009, Lawrence Livermore National Security Limited Liability
     41  ! Corporation.
     42  ! All rights reserved.
     43  !
     44  ! Redistribution and use in source and binary forms, with or without
     45  ! modification, are permitted provided that the
     46  ! following conditions are met:
     47  !
     48  ! * Redistributions of source code must retain the above
     49  !   copyright  notice, this list of conditions and the following
     50  !   disclaimer.
     51  ! * Redistributions in binary form must reproduce the above
     52  !   copyright notice, this list of conditions and the following
     53  !   disclaimer in the documentation and/or other materials
     54  !   provided with the distribution.
     55  ! * Neither the name of the Lawrence Livermore National Security
     56  !   Limited Liability Corporation nor the names of its
     57  !   contributors may be used to endorse or promote products
     58  !   derived from this software without specific prior written
     59  !   permission.
     60  !
     61  ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
     62  ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
     63  ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
     64  ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
     65  ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
     66  ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
     67  ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
     68  ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
     69  ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
     70  ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
     71  ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     72  !
     73  ! *****************************COPYRIGHT*******************************
     74  ! *****************************COPYRIGHT*******************************
     75  ! *****************************COPYRIGHT*******************************
     76  ! *****************************COPYRIGHT*******************************
     77
     78  implicit none
     79
     80  ! NOTE:   the maximum number of levels and columns is set by
     81  !         the following parameter statement
     82
     83  INTEGER :: ncolprint
     84
     85  ! -----
     86  ! Input
     87  ! -----
     88
     89  INTEGER :: npoints       !  number of model points in the horizontal
     90  INTEGER :: nlev          !  number of model levels in column
     91  INTEGER :: ncol          !  number of subcolumns
     92
     93  INTEGER :: sunlit(npoints) !  1 for day points, 0 for night time
     94
     95  REAL :: pfull(npoints,nlev)
     96                   ! !  pressure of full model levels (Pascals)
     97              ! !  pfull(npoints,1) is top level of model
     98              ! !  pfull(npoints,nlev) is bot of model
     99
     100  REAL :: phalf(npoints,nlev+1)
     101              ! !  pressure of half model levels (Pascals)
     102              ! !  phalf(npoints,1) is top of model
     103              ! !  phalf(npoints,nlev+1) is the surface pressure
     104
     105  REAL :: qv(npoints,nlev)
     106              ! !  water vapor specific humidity (kg vapor/ kg air)
     107              ! !         on full model levels
     108
     109  REAL :: cc(npoints,nlev)
     110              ! !  input cloud cover in each model level (fraction)
     111              ! !  NOTE:  This is the HORIZONTAL area of each
     112              ! !         grid box covered by clouds
     113
     114  REAL :: conv(npoints,nlev)
     115              ! !  input convective cloud cover in each model
     116              ! !   level (fraction)
     117              ! !  NOTE:  This is the HORIZONTAL area of each
     118              ! !         grid box covered by convective clouds
     119
     120  REAL :: dtau_s(npoints,nlev)
     121              ! !  mean 0.67 micron optical depth of stratiform
     122            ! !  clouds in each model level
     123            !   !  NOTE:  this the cloud optical depth of only the
     124            !   !  cloudy part of the grid box, it is not weighted
     125            !   !  with the 0 cloud optical depth of the clear
     126            !   !         part of the grid box
     127
     128  REAL :: dtau_c(npoints,nlev)
     129              ! !  mean 0.67 micron optical depth of convective
     130            ! !  clouds in each
     131            !   !  model level.  Same note applies as in dtau_s.
     132
     133  INTEGER :: overlap                   !  overlap type
     134                          ! !  1=max
     135                          ! !  2=rand
     136                          ! !  3=max/rand
     137
     138  INTEGER :: top_height                !  1 = adjust top height using both a computed
     139                                    ! !  infrared brightness temperature and the visible
     140                          ! !  optical depth to adjust cloud top pressure. Note
     141                          ! !  that this calculation is most appropriate to compare
     142                          ! !  to ISCCP data during sunlit hours.
     143                          !           !  2 = do not adjust top height, that is cloud top
     144                          !           !  pressure is the actual cloud top pressure
     145                          !           !  in the model
     146                          ! !  3 = adjust top height using only the computed
     147                          ! !  infrared brightness temperature. Note that this
     148                          ! !  calculation is most appropriate to compare to ISCCP
     149                          ! !  IR only algortihm (i.e. you can compare to nighttime
     150                          ! !  ISCCP data with this option)
     151
     152  INTEGER :: top_height_direction ! direction for finding atmosphere pressure level
     153                             ! ! with interpolated temperature equal to the radiance
     154                             ! determined cloud-top temperature
     155                             !
     156                             ! 1 = find the *lowest* altitude (highest pressure) level
     157                             ! with interpolated temperature equal to the radiance
     158                             ! determined cloud-top temperature
     159                             !
     160                             ! 2 = find the *highest* altitude (lowest pressure) level
     161                             ! with interpolated temperature equal to the radiance
     162                             ! determined cloud-top temperature
     163                             !
     164                             ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
     165                             !                           !
     166                             ! 1 = old setting: matches all versions of
     167                             ! ISCCP simulator with versions numbers 3.5.1 and lower
     168                             !
     169                             ! 2 = default setting: for version numbers 4.0 and higher
     170  !
     171  ! The following input variables are used only if top_height = 1 or top_height = 3
     172  !
     173  REAL :: skt(npoints)                 !  skin Temperature (K)
     174  REAL :: emsfc_lw                     !  10.5 micron emissivity of surface (fraction)
     175  REAL :: at(npoints,nlev)                   !  temperature in each model level (K)
     176  REAL :: dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
     177                          ! !  clouds in each
     178                          !           !  model level.  Same note applies as in dtau_s.
     179  REAL :: dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
     180                          ! !  clouds in each
     181                          !           !  model level.  Same note applies as in dtau_s.
     182
     183  REAL :: frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
     184                          ! ! Equivalent of BOX in original version, but
     185                          ! ! indexed by column then row, rather than
     186                          ! ! by row then column
     187
     188
     189
     190  ! ------
     191  ! Output
     192  ! ------
     193
     194  REAL :: fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
     195                                    ! !  each of the 49 ISCCP D level cloud types
     196
     197  REAL :: totalcldarea(npoints)        !  the fraction of model grid box columns
     198                                    ! !  with cloud somewhere in them.  NOTE: This diagnostic
     199                                    ! does not count model clouds with tau < isccp_taumin
     200                          ! ! Thus this diagnostic does not equal the sum over all entries of fq_isccp.
     201                          ! However, this diagnostic does equal the sum over entries of fq_isccp with
     202                          ! itau = 2:7 (omitting itau = 1)
     203
     204
     205  ! ! The following three means are averages only over the cloudy areas with tau > isccp_taumin.
     206  ! ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero.
     207
     208  REAL :: meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
     209                                    ! !  in cloud top pressure.
     210
     211  REAL :: meantaucld(npoints)          !  mean optical thickness
     212                                    ! !  linear averaging in albedo performed.
     213
     214  real :: meanalbedocld(npoints)        ! mean cloud albedo
     215                                    ! ! linear averaging in albedo performed
     216
     217  real :: meantb(npoints)              ! mean all-sky 10.5 micron brightness temperature
     218
     219  real :: meantbclr(npoints)           ! mean clear-sky 10.5 micron brightness temperature
     220
     221  REAL :: boxtau(npoints,ncol)         !  optical thickness in each column
     222
     223  REAL :: boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column
     224
     225
     226  !
     227  ! ------
     228  ! Working variables added when program updated to mimic Mark Webb's PV-Wave code
     229  ! ------
     230
     231  REAL :: dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave
     232                          ! !  emissivity in part of
     233                          ! !  gridbox under consideration
     234
     235  REAL :: ptrop(npoints)
     236  REAL :: attrop(npoints)
     237  REAL :: attropmin (npoints)
     238  REAL :: atmax(npoints)
     239  REAL :: btcmin(npoints)
     240  REAL :: transmax(npoints)
     241
     242  INTEGER :: i,j,ilev,ibox,itrop(npoints)
     243  INTEGER :: ipres(npoints)
     244  INTEGER :: itau(npoints),ilev2
     245  INTEGER :: acc(nlev,ncol)
     246  INTEGER :: match(npoints,nlev-1)
     247  INTEGER :: nmatch(npoints)
     248  INTEGER :: levmatch(npoints,ncol)
     249
     250  ! !variables needed for water vapor continuum absorption
     251  real :: fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
     252  real :: taumin(npoints)
     253  real :: dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
     254  real :: press(npoints), dpress(npoints), atmden(npoints)
     255  real :: rvh20(npoints), wk(npoints), rhoave(npoints)
     256  real :: rh20s(npoints), rfrgn(npoints)
     257  real :: tmpexp(npoints),tauwv(npoints)
     258
     259  character(len=1) :: cchar(6),cchar_realtops(6)
     260  integer :: icycle
     261  REAL :: tau(npoints,ncol)
     262  LOGICAL :: box_cloudy(npoints,ncol)
     263  REAL :: tb(npoints,ncol)
     264  REAL :: ptop(npoints,ncol)
     265  REAL :: emcld(npoints,ncol)
     266  REAL :: fluxtop(npoints,ncol)
     267  REAL :: trans_layers_above(npoints,ncol)
     268  real :: isccp_taumin,fluxtopinit(npoints),tauir(npoints)
     269  REAL :: albedocld(npoints,ncol)
     270  real :: boxarea
     271  integer :: debug       ! set to non-zero value to print out inputs
     272                ! ! with step debug
     273  integer :: debugcol    ! set to non-zero value to print out column
     274                ! ! decomposition with step debugcol
     275  integer :: rangevec(npoints),rangeerror
     276
     277  integer :: index1(npoints),num1,jj,k1,k2
     278  real :: rec2p13,tauchk,logp,logp1,logp2,atd
     279  real :: output_missing_value
     280
     281  character(len=10) :: ftn09
     282
     283  DATA isccp_taumin / 0.3 /
     284  DATA output_missing_value / -1.E+30 /
     285  DATA cchar / ' ','-','1','+','I','+'/
     286  DATA cchar_realtops / ' ',' ','1','1','I','I'/
     287
     288  ! ------ End duplicate definitions common to wrapper routine
     289
     290  tauchk = -1.*log(0.9999999)
     291  rec2p13=1./2.13
     292
     293  ncolprint=0
     294
     295  if ( debug.ne.0 ) then
     296      j=1
     297      write(6,'(a10)') 'j='
     298      write(6,'(8I10)') j
     299      write(6,'(a10)') 'debug='
     300      write(6,'(8I10)') debug
     301      write(6,'(a10)') 'debugcol='
     302      write(6,'(8I10)') debugcol
     303      write(6,'(a10)') 'npoints='
     304      write(6,'(8I10)') npoints
     305      write(6,'(a10)') 'nlev='
     306      write(6,'(8I10)') nlev
     307      write(6,'(a10)') 'ncol='
     308      write(6,'(8I10)') ncol
     309      write(6,'(a11)') 'top_height='
     310      write(6,'(8I10)') top_height
     311      write(6,'(a21)') 'top_height_direction='
     312      write(6,'(8I10)') top_height_direction
     313      write(6,'(a10)') 'overlap='
     314      write(6,'(8I10)') overlap
     315      write(6,'(a10)') 'emsfc_lw='
     316      write(6,'(8f10.2)') emsfc_lw
     317    do j=1,npoints,debug
     318      write(6,'(a10)') 'j='
     319      write(6,'(8I10)') j
     320      write(6,'(a10)') 'sunlit='
     321      write(6,'(8I10)') sunlit(j)
     322      write(6,'(a10)') 'pfull='
     323      write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
     324      write(6,'(a10)') 'phalf='
     325      write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
     326      write(6,'(a10)') 'qv='
     327      write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
     328      write(6,'(a10)') 'cc='
     329      write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
     330      write(6,'(a10)') 'conv='
     331      write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
     332      write(6,'(a10)') 'dtau_s='
     333      write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
     334      write(6,'(a10)') 'dtau_c='
     335      write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
     336      write(6,'(a10)') 'skt='
     337      write(6,'(8f10.2)') skt(j)
     338      write(6,'(a10)') 'at='
     339      write(6,'(8f10.2)') (at(j,i),i=1,nlev)
     340      write(6,'(a10)') 'dem_s='
     341      write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
     342      write(6,'(a10)') 'dem_c='
     343      write(6,'(8f10.3)') (dem_c(j,i),i=1,nlev)
     344    enddo
     345  endif
     346
     347  ! ---------------------------------------------------!
     348
     349  if (ncolprint.ne.0) then
     350  do j=1,npoints,1000
     351    write(6,'(a10)') 'j='
     352    write(6,'(8I10)') j
     353  enddo
     354  endif
     355
     356  if (top_height .eq. 1 .or. top_height .eq. 3) then
     357
     358  do j=1,npoints
     359      ptrop(j)=5000.
     360      attropmin(j) = 400.
     361      atmax(j) = 0.
     362      attrop(j) = 120.
     363      itrop(j) = 1
     364  enddo
     365
     366  do ilev=1,nlev
     367    do j=1,npoints
     368     if (pfull(j,ilev) .lt. 40000. .and. &
     369           pfull(j,ilev) .gt.  5000. .and. &
     370           at(j,ilev) .lt. attropmin(j)) then
     371            ptrop(j) = pfull(j,ilev)
     372            attropmin(j) = at(j,ilev)
     373            attrop(j) = attropmin(j)
     374            itrop(j)=ilev
     375       end if
     376    enddo
     377  end do
     378
     379  do ilev=1,nlev
     380    do j=1,npoints
     381       if (at(j,ilev) .gt. atmax(j) .and. &
     382             ilev  .ge. itrop(j)) atmax(j)=at(j,ilev)
     383    enddo
     384  end do
     385
     386  end if
     387
     388
     389  if (top_height .eq. 1 .or. top_height .eq. 3) then
     390      do j=1,npoints
     391          meantb(j) = 0.
     392          meantbclr(j) = 0.
     393      end do
     394  else
     395      do j=1,npoints
     396          meantb(j) = output_missing_value
     397          meantbclr(j) = output_missing_value
     398      end do
     399  end if
     400
     401  ! -----------------------------------------------------!
     402
     403  ! ---------------------------------------------------!
     404
     405  do ilev=1,nlev
     406    do j=1,npoints
     407
     408      rangevec(j)=0
     409
     410      if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
     411        ! error = cloud fraction less than zero
     412        ! error = cloud fraction greater than 1
     413        rangevec(j)=rangevec(j)+1
     414      endif
     415
     416      if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
     417        ! ' error = convective cloud fraction less than zero'
     418        ! ' error = convective cloud fraction greater than 1'
     419        rangevec(j)=rangevec(j)+2
     420      endif
     421
     422      if (dtau_s(j,ilev) .lt. 0.) then
     423        ! ' error = stratiform cloud opt. depth less than zero'
     424        rangevec(j)=rangevec(j)+4
     425      endif
     426
     427      if (dtau_c(j,ilev) .lt. 0.) then
     428        ! ' error = convective cloud opt. depth less than zero'
     429        rangevec(j)=rangevec(j)+8
     430      endif
     431
     432      if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
     433          ! ' error = stratiform cloud emissivity less than zero'
     434          ! ' error = stratiform cloud emissivity greater than 1'
     435        rangevec(j)=rangevec(j)+16
     436      endif
     437
     438      if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
     439          ! ' error = convective cloud emissivity less than zero'
     440          ! ' error = convective cloud emissivity greater than 1'
     441          rangevec(j)=rangevec(j)+32
     442      endif
     443    enddo
     444
     445    rangeerror=0
     446    do j=1,npoints
     447        rangeerror=rangeerror+rangevec(j)
     448    enddo
     449
     450    if (rangeerror.ne.0) then
     451          write (6,*) 'Input variable out of range'
     452          write (6,*) 'rangevec:'
     453          write (6,*) rangevec
     454          STOP
     455    endif
     456  enddo
     457
     458  !
     459  ! ---------------------------------------------------!
     460
     461
     462  !
     463  ! ---------------------------------------------------!
     464  ! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and
     465  ! put into vector tau
     466
     467  ! !initialize tau and albedocld to zero
     468  do ibox=1,ncol
     469    do j=1,npoints
     470        tau(j,ibox)=0.
     471      albedocld(j,ibox)=0.
     472      boxtau(j,ibox)=output_missing_value
     473      boxptop(j,ibox)=output_missing_value
     474      box_cloudy(j,ibox)=.false.
     475    enddo
     476  end do
     477
     478  ! !compute total cloud optical depth for each column
     479  do ilev=1,nlev
     480        ! !increment tau for each of the boxes
     481        do ibox=1,ncol
     482          do j=1,npoints
     483             if (frac_out(j,ibox,ilev).eq.1) then
     484                    tau(j,ibox)=tau(j,ibox) &
     485                          + dtau_s(j,ilev)
     486             endif
     487             if (frac_out(j,ibox,ilev).eq.2) then
     488                    tau(j,ibox)=tau(j,ibox) &
     489                          + dtau_c(j,ilev)
     490             end if
     491          enddo
     492        enddo ! ibox
     493  enddo ! ilev
     494      if (ncolprint.ne.0) then
     495
     496          do j=1,npoints ,1000
     497            write(6,'(a10)') 'j='
     498            write(6,'(8I10)') j
     499            write(6,'(i2,1X,8(f7.2,1X))') &
     500                  ilev, &
     501                  (tau(j,ibox),ibox=1,ncolprint)
     502          enddo
     503      endif
     504  !
     505  ! ---------------------------------------------------!
     506
     507
     508
     509  !
     510  ! ---------------------------------------------------!
     511  ! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES
     512  ! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE
     513  !
     514  ! again this is only done if top_height = 1 or 3
     515  !
     516  ! fluxtop is the 10.5 micron radiance at the top of the
     517  !          atmosphere
     518  ! trans_layers_above is the total transmissivity in the layers
     519  !         above the current layer
     520  ! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear
     521  !         sky versions of these quantities.
     522
     523  if (top_height .eq. 1 .or. top_height .eq. 3) then
     524
     525
     526    ! !----------------------------------------------------------------------
     527    ! !
     528    ! !             DO CLEAR SKY RADIANCE CALCULATION FIRST
     529    ! !
     530    ! !compute water vapor continuum emissivity
     531    ! !this treatment follows Schwarkzopf and Ramasamy
     532    ! !JGR 1999,vol 104, pages 9467-9499.
     533    ! !the emissivity is calculated at a wavenumber of 955 cm-1,
     534    ! !or 10.47 microns
     535    wtmair = 28.9644
     536    wtmh20 = 18.01534
     537    Navo = 6.023E+23
     538    grav = 9.806650E+02
     539    pstd = 1.013250E+06
     540    t0 = 296.
     541    if (ncolprint .ne. 0) &
     542          write(6,*)  'ilev   pw (kg/m2)   tauwv(j)      dem_wv'
     543    do ilev=1,nlev
     544      do j=1,npoints
     545           ! !press and dpress are dyne/cm2 = Pascals *10
     546           press(j) = pfull(j,ilev)*10.
     547           dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10
     548           ! !atmden = g/cm2 = kg/m2 / 10
     549           atmden(j) = dpress(j)/grav
     550           rvh20(j) = qv(j,ilev)*wtmair/wtmh20
     551           wk(j) = rvh20(j)*Navo*atmden(j)/wtmair
     552           rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev))
     553           rh20s(j) = rvh20(j)*rhoave(j)
     554           rfrgn(j) = rhoave(j)-rh20s(j)
     555           tmpexp(j) = exp(-0.02*(at(j,ilev)-t0))
     556           tauwv(j) = wk(j)*1.e-20*( &
     557                 (0.0224697*rh20s(j)*tmpexp(j)) + &
     558                 (3.41817e-7*rfrgn(j)) )*0.98
     559           dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j))
     560      enddo
     561           if (ncolprint .ne. 0) then
     562           do j=1,npoints ,1000
     563           write(6,'(a10)') 'j='
     564           write(6,'(8I10)') j
     565           write(6,'(i2,1X,3(f8.3,3X))') ilev, &
     566                 qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.), &
     567                 tauwv(j),dem_wv(j,ilev)
     568           enddo
     569         endif
     570    end do
     571
     572    ! !initialize variables
     573    do j=1,npoints
     574      fluxtop_clrsky(j) = 0.
     575      trans_layers_above_clrsky(j)=1.
     576    enddo
     577
     578    do ilev=1,nlev
     579      do j=1,npoints
     580
     581        ! ! Black body emission at temperature of the layer
     582
     583          bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
     584          ! !bb(j)= 5.67e-8*at(j,ilev)**4
     585
     586          ! ! increase TOA flux by flux emitted from layer
     587          ! ! times total transmittance in layers above
     588
     589            fluxtop_clrsky(j) = fluxtop_clrsky(j) &
     590                  + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j)
     591
     592            ! ! update trans_layers_above with transmissivity
     593          ! ! from this layer for next time around loop
     594
     595            trans_layers_above_clrsky(j)= &
     596                  trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev))
     597
     598
     599      enddo
     600        if (ncolprint.ne.0) then
     601         do j=1,npoints ,1000
    297602          write(6,'(a10)') 'j='
    298603          write(6,'(8I10)') j
    299           write(6,'(a10)') 'debug='
    300           write(6,'(8I10)') debug
    301           write(6,'(a10)') 'debugcol='
    302           write(6,'(8I10)') debugcol
    303           write(6,'(a10)') 'npoints='
    304           write(6,'(8I10)') npoints
    305           write(6,'(a10)') 'nlev='
    306           write(6,'(8I10)') nlev
    307           write(6,'(a10)') 'ncol='
    308           write(6,'(8I10)') ncol
    309           write(6,'(a11)') 'top_height='
    310           write(6,'(8I10)') top_height
    311           write(6,'(a21)') 'top_height_direction='
    312           write(6,'(8I10)') top_height_direction
    313           write(6,'(a10)') 'overlap='
    314           write(6,'(8I10)') overlap
    315           write(6,'(a10)') 'emsfc_lw='
    316           write(6,'(8f10.2)') emsfc_lw
    317         do j=1,npoints,debug
     604          write (6,'(a)') 'ilev:'
     605          write (6,'(I2)') ilev
     606
     607          write (6,'(a)') &
     608                'emiss_layer,100.*bb(j),100.*f,total_trans:'
     609          write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j), &
     610                100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
     611         enddo
     612        endif
     613
     614    enddo   !loop over level
     615
     616    do j=1,npoints
     617      ! !add in surface emission
     618      bb(j)=1/( exp(1307.27/skt(j)) - 1. )
     619      ! !bb(j)=5.67e-8*skt(j)**4
     620
     621      fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j) &
     622            * trans_layers_above_clrsky(j)
     623
     624      ! !clear sky brightness temperature
     625      meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
     626
     627    enddo
     628
     629    if (ncolprint.ne.0) then
     630    do j=1,npoints ,1000
     631      write(6,'(a10)') 'j='
     632      write(6,'(8I10)') j
     633      write (6,'(a)') 'id:'
     634      write (6,'(a)') 'surface'
     635
     636      write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
     637      write (6,'(5(f7.2,1X))') emsfc_lw,100.*bb(j), &
     638            100.*fluxtop_clrsky(j), &
     639            trans_layers_above_clrsky(j), meantbclr(j)
     640    enddo
     641  endif
     642
     643
     644    ! !
     645    ! !           END OF CLEAR SKY CALCULATION
     646    ! !
     647    ! !----------------------------------------------------------------
     648
     649
     650
     651    if (ncolprint.ne.0) then
     652
     653    do j=1,npoints ,1000
     654        write(6,'(a10)') 'j='
     655        write(6,'(8I10)') j
     656        write (6,'(a)') 'ts:'
     657        write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)
     658
     659        write (6,'(a)') 'ta_rev:'
     660        write (6,'(8f7.2)') &
     661              ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
     662
     663    enddo
     664    endif
     665    ! !loop over columns
     666    do ibox=1,ncol
     667      do j=1,npoints
     668        fluxtop(j,ibox)=0.
     669        trans_layers_above(j,ibox)=1.
     670      enddo
     671    enddo
     672
     673    do ilev=1,nlev
     674          do j=1,npoints
     675            ! ! Black body emission at temperature of the layer
     676
     677          bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
     678          ! !bb(j)= 5.67e-8*at(j,ilev)**4
     679          enddo
     680
     681        do ibox=1,ncol
     682          do j=1,npoints
     683
     684          ! ! emissivity for point in this layer
     685            if (frac_out(j,ibox,ilev).eq.1) then
     686            dem(j,ibox)= 1. - &
     687                  ( (1. - dem_wv(j,ilev)) * (1. -  dem_s(j,ilev)) )
     688            else if (frac_out(j,ibox,ilev).eq.2) then
     689            dem(j,ibox)= 1. - &
     690                  ( (1. - dem_wv(j,ilev)) * (1. -  dem_c(j,ilev)) )
     691            else
     692            dem(j,ibox)=  dem_wv(j,ilev)
     693            end if
     694
     695
     696            ! ! increase TOA flux by flux emitted from layer
     697          ! ! times total transmittance in layers above
     698
     699            fluxtop(j,ibox) = fluxtop(j,ibox) &
     700                  + dem(j,ibox) * bb(j) &
     701                  * trans_layers_above(j,ibox)
     702
     703            ! ! update trans_layers_above with transmissivity
     704          ! ! from this layer for next time around loop
     705
     706            trans_layers_above(j,ibox)= &
     707                  trans_layers_above(j,ibox)*(1.-dem(j,ibox))
     708
     709          enddo ! j
     710        enddo ! ibox
     711
     712        if (ncolprint.ne.0) then
     713          do j=1,npoints,1000
     714          write (6,'(a)') 'ilev:'
     715          write (6,'(I2)') ilev
     716
    318717          write(6,'(a10)') 'j='
    319718          write(6,'(8I10)') j
    320           write(6,'(a10)') 'sunlit='
    321           write(6,'(8I10)') sunlit(j)
    322           write(6,'(a10)') 'pfull='
    323           write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
    324           write(6,'(a10)') 'phalf='
    325           write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
    326           write(6,'(a10)') 'qv='
    327           write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
    328           write(6,'(a10)') 'cc='
    329           write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
    330           write(6,'(a10)') 'conv='
    331           write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
    332           write(6,'(a10)') 'dtau_s='
    333           write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
    334           write(6,'(a10)') 'dtau_c='
    335           write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
    336           write(6,'(a10)') 'skt='
    337           write(6,'(8f10.2)') skt(j)
    338           write(6,'(a10)') 'at='
    339           write(6,'(8f10.2)') (at(j,i),i=1,nlev)
    340           write(6,'(a10)') 'dem_s='
    341           write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
    342           write(6,'(a10)') 'dem_c='
    343           write(6,'(8f10.3)') (dem_c(j,i),i=1,nlev)
     719          write (6,'(a)') 'emiss_layer:'
     720          write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
     721
     722          write (6,'(a)') '100.*bb(j):'
     723          write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
     724
     725          write (6,'(a)') '100.*f:'
     726          write (6,'(8f7.2)') &
     727                (100.*fluxtop(j,ibox),ibox=1,ncolprint)
     728
     729          write (6,'(a)') 'total_trans:'
     730          write (6,'(8f7.2)') &
     731                (trans_layers_above(j,ibox),ibox=1,ncolprint)
    344732        enddo
    345733      endif
    346734
    347 !     ---------------------------------------------------!
    348 
    349       if (ncolprint.ne.0) then
     735    enddo ! ilev
     736
     737
     738      do j=1,npoints
     739        ! !add in surface emission
     740        bb(j)=1/( exp(1307.27/skt(j)) - 1. )
     741        ! !bb(j)=5.67e-8*skt(j)**4
     742      end do
     743
     744    do ibox=1,ncol
     745      do j=1,npoints
     746
     747        ! !add in surface emission
     748
     749        fluxtop(j,ibox) = fluxtop(j,ibox) &
     750              + emsfc_lw * bb(j) &
     751              * trans_layers_above(j,ibox)
     752
     753      end do
     754    end do
     755
     756    ! !calculate mean infrared brightness temperature
     757    do ibox=1,ncol
     758      do j=1,npoints
     759        meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox))))
     760      end do
     761    end do
     762      do j=1, npoints
     763        meantb(j) = meantb(j) / real(ncol)
     764      end do
     765
     766    if (ncolprint.ne.0) then
     767
     768      do j=1,npoints ,1000
     769      write(6,'(a10)') 'j='
     770      write(6,'(8I10)') j
     771      write (6,'(a)') 'id:'
     772      write (6,'(a)') 'surface'
     773
     774      write (6,'(a)') 'emiss_layer:'
     775      write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
     776
     777      write (6,'(a)') '100.*bb(j):'
     778      write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
     779
     780      write (6,'(a)') '100.*f:'
     781      write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
     782
     783      write (6,'(a)') 'meantb(j):'
     784      write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint)
     785
     786      end do
     787  endif
     788
     789    ! !now that you have the top of atmosphere radiance account
     790    ! !for ISCCP procedures to determine cloud top temperature
     791
     792    ! !account for partially transmitting cloud recompute flux
     793    ! !ISCCP would see assuming a single layer cloud
     794    ! !note choice here of 2.13, as it is primarily ice
     795    ! !clouds which have partial emissivity and need the
     796    ! !adjustment performed in this section
     797    ! !
     798  ! !If it turns out that the cloud brightness temperature
     799  ! !is greater than 260K, then the liquid cloud conversion
     800  !   !factor of 2.56 is used.
     801  ! !
     802  !   !Note that this is discussed on pages 85-87 of
     803  !   !the ISCCP D level documentation (Rossow et al. 1996)
     804
     805      do j=1,npoints
     806        ! !compute minimum brightness temperature and optical depth
     807        btcmin(j) = 1. /  ( exp(1307.27/(attrop(j)-5.)) - 1. )
     808      enddo
     809    do ibox=1,ncol
     810      do j=1,npoints
     811        transmax(j) = (fluxtop(j,ibox)-btcmin(j)) &
     812              /(fluxtop_clrsky(j)-btcmin(j))
     813      ! !note that the initial setting of tauir(j) is needed so that
     814      ! !tauir(j) has a realistic value should the next if block be
     815      ! !bypassed
     816        tauir(j) = tau(j,ibox) * rec2p13
     817        taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001))
     818
     819      enddo
     820
     821      if (top_height .eq. 1) then
     822        do j=1,npoints
     823          if (transmax(j) .gt. 0.001 .and. &
     824                transmax(j) .le. 0.9999999) then
     825            fluxtopinit(j) = fluxtop(j,ibox)
     826          tauir(j) = tau(j,ibox) *rec2p13
     827          endif
     828        enddo
     829        do icycle=1,2
     830          do j=1,npoints
     831            if (tau(j,ibox) .gt. (tauchk            )) then
     832            if (transmax(j) .gt. 0.001 .and. &
     833                  transmax(j) .le. 0.9999999) then
     834              emcld(j,ibox) = 1. - exp(-1. * tauir(j)  )
     835              fluxtop(j,ibox) = fluxtopinit(j) - &
     836                    ((1.-emcld(j,ibox))*fluxtop_clrsky(j))
     837              fluxtop(j,ibox)=max(1.E-06, &
     838                    (fluxtop(j,ibox)/emcld(j,ibox)))
     839              tb(j,ibox)= 1307.27 &
     840                    / (log(1. + (1./fluxtop(j,ibox))))
     841              if (tb(j,ibox) .gt. 260.) then
     842              tauir(j) = tau(j,ibox) / 2.56
     843              end if
     844            end if
     845            end if
     846          enddo
     847        enddo
     848
     849      endif
     850
     851      do j=1,npoints
     852        if (tau(j,ibox) .gt. (tauchk            )) then
     853            ! !cloudy box
     854            !NOTE: tb is the cloud-top temperature not infrared brightness temperature
     855            !at this point in the code
     856            tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox))))
     857            if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then
     858                     tb(j,ibox) = attrop(j) - 5.
     859               tau(j,ibox) = 2.13*taumin(j)
     860            end if
     861        else
     862            ! !clear sky brightness temperature
     863            tb(j,ibox) = meantbclr(j)
     864        end if
     865      enddo ! j
     866    enddo ! ibox
     867
     868    if (ncolprint.ne.0) then
     869
    350870      do j=1,npoints,1000
    351         write(6,'(a10)') 'j='
    352         write(6,'(8I10)') j
     871      write(6,'(a10)') 'j='
     872      write(6,'(8I10)') j
     873
     874      write (6,'(a)') 'attrop:'
     875      write (6,'(8f7.2)') (attrop(j))
     876
     877      write (6,'(a)') 'btcmin:'
     878      write (6,'(8f7.2)') (btcmin(j))
     879
     880      write (6,'(a)') 'fluxtop_clrsky*100:'
     881      write (6,'(8f7.2)') &
     882            (100.*fluxtop_clrsky(j))
     883
     884      write (6,'(a)') '100.*f_adj:'
     885      write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
     886
     887      write (6,'(a)') 'transmax:'
     888      write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
     889
     890      write (6,'(a)') 'tau:'
     891      write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
     892
     893      write (6,'(a)') 'emcld:'
     894      write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
     895
     896      write (6,'(a)') 'total_trans:'
     897      write (6,'(8f7.2)') &
     898            (trans_layers_above(j,ibox),ibox=1,ncolprint)
     899
     900      write (6,'(a)') 'total_emiss:'
     901      write (6,'(8f7.2)') &
     902            (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
     903
     904      write (6,'(a)') 'total_trans:'
     905      write (6,'(8f7.2)') &
     906            (trans_layers_above(j,ibox),ibox=1,ncolprint)
     907
     908      write (6,'(a)') 'ppout:'
     909      write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
     910      enddo ! j
     911  endif
     912
     913  end if
     914
     915  ! ---------------------------------------------------!
     916
     917  !
     918  ! ---------------------------------------------------!
     919  ! DETERMINE CLOUD TOP PRESSURE
     920  !
     921  ! again the 2 methods differ according to whether
     922  ! or not you use the physical cloud top pressure (top_height = 2)
     923  ! or the radiatively determined cloud top pressure (top_height = 1 or 3)
     924  !
     925
     926  ! !compute cloud top pressure
     927  do ibox=1,ncol
     928    ! !segregate according to optical thickness
     929    if (top_height .eq. 1 .or. top_height .eq. 3) then
     930      ! !find level whose temperature
     931      ! !most closely matches brightness temperature
     932      do j=1,npoints
     933        nmatch(j)=0
    353934      enddo
    354       endif
    355 
    356       if (top_height .eq. 1 .or. top_height .eq. 3) then
    357 
    358       do j=1,npoints
    359           ptrop(j)=5000.
    360           attropmin(j) = 400.
    361           atmax(j) = 0.
    362           attrop(j) = 120.
    363           itrop(j) = 1
    364       enddo
    365 
    366       do 12 ilev=1,nlev
    367         do j=1,npoints
    368          if (pfull(j,ilev) .lt. 40000. .and.
    369      &          pfull(j,ilev) .gt.  5000. .and.
    370      &          at(j,ilev) .lt. attropmin(j)) then
    371                 ptrop(j) = pfull(j,ilev)
    372                 attropmin(j) = at(j,ilev)
    373                 attrop(j) = attropmin(j)
    374                 itrop(j)=ilev
    375            end if
     935      do k1=1,nlev-1
     936        if (top_height_direction .eq. 2) then
     937          ilev = nlev - k1
     938        else
     939          ilev = k1
     940        end if
     941        ! !cdir nodep
     942        do j=1,npoints
     943         if (ilev .ge. itrop(j)) then
     944          if ((at(j,ilev)   .ge. tb(j,ibox) .and. &
     945                at(j,ilev+1) .le. tb(j,ibox)) .or. &
     946                (at(j,ilev) .le. tb(j,ibox) .and. &
     947                at(j,ilev+1) .ge. tb(j,ibox))) then
     948            nmatch(j)=nmatch(j)+1
     949            match(j,nmatch(j))=ilev
     950          end if
     951         end if
    376952        enddo
    377 12    continue
    378 
    379       do 13 ilev=1,nlev
    380         do j=1,npoints
    381            if (at(j,ilev) .gt. atmax(j) .and.
    382      &              ilev  .ge. itrop(j)) atmax(j)=at(j,ilev)
    383         enddo
    384 13    continue
    385 
    386       end if
    387 
    388 
    389       if (top_height .eq. 1 .or. top_height .eq. 3) then
    390           do j=1,npoints
    391               meantb(j) = 0.
    392               meantbclr(j) = 0.
    393           end do
    394       else
    395           do j=1,npoints
    396               meantb(j) = output_missing_value
    397               meantbclr(j) = output_missing_value
    398           end do
    399       end if
    400      
    401 !     -----------------------------------------------------!
    402 
    403 !     ---------------------------------------------------!
    404 
     953      end do
     954
     955      do j=1,npoints
     956        if (nmatch(j) .ge. 1) then
     957          k1 = match(j,nmatch(j))
     958          k2 = k1 + 1
     959          logp1 = log(pfull(j,k1))
     960          logp2 = log(pfull(j,k2))
     961          atd = max(tauchk,abs(at(j,k2) - at(j,k1)))
     962          logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd
     963          ptop(j,ibox) = exp(logp)
     964          if(abs(pfull(j,k1)-ptop(j,ibox)) .lt. &
     965                abs(pfull(j,k2)-ptop(j,ibox))) then
     966             levmatch(j,ibox)=k1
     967          else
     968             levmatch(j,ibox)=k2
     969          end if
     970        else
     971          if (tb(j,ibox) .le. attrop(j)) then
     972            ptop(j,ibox)=ptrop(j)
     973            levmatch(j,ibox)=itrop(j)
     974          end if
     975          if (tb(j,ibox) .ge. atmax(j)) then
     976            ptop(j,ibox)=pfull(j,nlev)
     977            levmatch(j,ibox)=nlev
     978          end if
     979        end if
     980      enddo ! j
     981
     982    else ! if (top_height .eq. 1 .or. top_height .eq. 3)
     983
     984      do j=1,npoints
     985        ptop(j,ibox)=0.
     986      enddo
    405987      do ilev=1,nlev
    406988        do j=1,npoints
    407 
    408           rangevec(j)=0
    409 
    410           if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
    411 !           error = cloud fraction less than zero
    412 !           error = cloud fraction greater than 1
    413             rangevec(j)=rangevec(j)+1
    414           endif
    415 
    416           if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
    417 !           ' error = convective cloud fraction less than zero'
    418 !           ' error = convective cloud fraction greater than 1'
    419             rangevec(j)=rangevec(j)+2
    420           endif
    421 
    422           if (dtau_s(j,ilev) .lt. 0.) then
    423 !           ' error = stratiform cloud opt. depth less than zero'
    424             rangevec(j)=rangevec(j)+4
    425           endif
    426 
    427           if (dtau_c(j,ilev) .lt. 0.) then
    428 !           ' error = convective cloud opt. depth less than zero'
    429             rangevec(j)=rangevec(j)+8
    430           endif
    431 
    432           if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
    433 !             ' error = stratiform cloud emissivity less than zero'
    434 !             ' error = stratiform cloud emissivity greater than 1'
    435             rangevec(j)=rangevec(j)+16
    436           endif
    437 
    438           if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
    439 !             ' error = convective cloud emissivity less than zero'
    440 !             ' error = convective cloud emissivity greater than 1'
    441               rangevec(j)=rangevec(j)+32
    442           endif
    443         enddo
    444 
    445         rangeerror=0
    446         do j=1,npoints
    447             rangeerror=rangeerror+rangevec(j)
    448         enddo
    449 
    450         if (rangeerror.ne.0) then
    451               write (6,*) 'Input variable out of range'
    452               write (6,*) 'rangevec:'
    453               write (6,*) rangevec
    454               STOP
     989          if ((ptop(j,ibox) .eq. 0. ) &
     990                .and.(frac_out(j,ibox,ilev) .ne. 0)) then
     991            ptop(j,ibox)=phalf(j,ilev)
     992          levmatch(j,ibox)=ilev
     993          end if
     994        end do
     995      end do
     996    end if
     997
     998    do j=1,npoints
     999      if (tau(j,ibox) .le. (tauchk            )) then
     1000        ptop(j,ibox)=0.
     1001        levmatch(j,ibox)=0
     1002      endif
     1003    enddo
     1004
     1005  end do
     1006
     1007  !
     1008  !
     1009  ! ---------------------------------------------------!
     1010
     1011
     1012  !
     1013  ! ---------------------------------------------------!
     1014  ! DETERMINE ISCCP CLOUD TYPE FREQUENCIES
     1015  !
     1016  ! Now that ptop and tau have been determined,
     1017  ! determine amount of each of the 49 ISCCP cloud
     1018  ! types
     1019  !
     1020  ! Also compute grid box mean cloud top pressure and
     1021  ! optical thickness.  The mean cloud top pressure and
     1022  ! optical thickness are averages over the cloudy
     1023  ! area only. The mean cloud top pressure is a linear
     1024  ! average of the cloud top pressures.  The mean cloud
     1025  ! optical thickness is computed by converting optical
     1026  ! thickness to an albedo, averaging in albedo units,
     1027  ! then converting the average albedo back to a mean
     1028  ! optical thickness.
     1029  !
     1030
     1031  ! !compute isccp frequencies
     1032
     1033  ! !reset frequencies
     1034  do ilev=1,7
     1035  do ilev2=1,7
     1036    do j=1,npoints !
     1037         if (sunlit(j).eq.1 .or. top_height .eq. 3) then
     1038            fq_isccp(j,ilev,ilev2)= 0.
     1039         else
     1040            fq_isccp(j,ilev,ilev2)= output_missing_value
     1041         end if
     1042    enddo
     1043  end do
     1044  end do
     1045
     1046  ! !reset variables need for averaging cloud properties
     1047  do j=1,npoints
     1048    if (sunlit(j).eq.1 .or. top_height .eq. 3) then
     1049         totalcldarea(j) = 0.
     1050         meanalbedocld(j) = 0.
     1051         meanptop(j) = 0.
     1052         meantaucld(j) = 0.
     1053    else
     1054         totalcldarea(j) = output_missing_value
     1055         meanalbedocld(j) = output_missing_value
     1056         meanptop(j) = output_missing_value
     1057         meantaucld(j) = output_missing_value
     1058    end if
     1059  enddo ! j
     1060
     1061  boxarea = 1./real(ncol)
     1062
     1063  do ibox=1,ncol
     1064    do j=1,npoints
     1065
     1066      if (tau(j,ibox) .gt. (tauchk            ) &
     1067            .and. ptop(j,ibox) .gt. 0.) then
     1068          box_cloudy(j,ibox)=.true.
     1069      endif
     1070
     1071      if (box_cloudy(j,ibox)) then
     1072
     1073          if (sunlit(j).eq.1 .or. top_height .eq. 3) then
     1074
     1075            boxtau(j,ibox) = tau(j,ibox)
     1076
     1077            if (tau(j,ibox) .ge. isccp_taumin) then
     1078               totalcldarea(j) = totalcldarea(j) + boxarea
     1079
     1080               ! !convert optical thickness to albedo
     1081               albedocld(j,ibox) &
     1082                     = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82)
     1083
     1084               ! !contribute to averaging
     1085               meanalbedocld(j) = meanalbedocld(j) &
     1086                     +albedocld(j,ibox)*boxarea
     1087
     1088            end if
     1089
    4551090        endif
    456       enddo
    457 
    458 !
    459 !     ---------------------------------------------------!
    460 
    461      
    462 !
    463 !     ---------------------------------------------------!
    464 !     COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and
    465 !     put into vector tau
    466  
    467       !initialize tau and albedocld to zero
    468       do 15 ibox=1,ncol
    469         do j=1,npoints
    470             tau(j,ibox)=0.
    471           albedocld(j,ibox)=0.
    472           boxtau(j,ibox)=output_missing_value
    473           boxptop(j,ibox)=output_missing_value
    474           box_cloudy(j,ibox)=.false.
    475         enddo
    476 15    continue
    477 
    478       !compute total cloud optical depth for each column     
    479       do ilev=1,nlev
    480             !increment tau for each of the boxes
    481             do ibox=1,ncol
    482               do j=1,npoints
    483                  if (frac_out(j,ibox,ilev).eq.1) then
    484                         tau(j,ibox)=tau(j,ibox)
    485      &                     + dtau_s(j,ilev)
    486                  endif
    487                  if (frac_out(j,ibox,ilev).eq.2) then
    488                         tau(j,ibox)=tau(j,ibox)
    489      &                     + dtau_c(j,ilev)
    490                  end if
    491               enddo
    492             enddo ! ibox
    493       enddo ! ilev
    494           if (ncolprint.ne.0) then
    495 
    496               do j=1,npoints ,1000
    497                 write(6,'(a10)') 'j='
    498                 write(6,'(8I10)') j
    499                 write(6,'(i2,1X,8(f7.2,1X))')
    500      &          ilev,
    501      &          (tau(j,ibox),ibox=1,ncolprint)
    502               enddo
    503           endif
    504 !
    505 !     ---------------------------------------------------!
    506 
    507 
    508 
    509 !     
    510 !     ---------------------------------------------------!
    511 !     COMPUTE INFRARED BRIGHTNESS TEMPERUATRES
    512 !     AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE
    513 !
    514 !     again this is only done if top_height = 1 or 3
    515 !
    516 !     fluxtop is the 10.5 micron radiance at the top of the
    517 !              atmosphere
    518 !     trans_layers_above is the total transmissivity in the layers
    519 !             above the current layer
    520 !     fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear
    521 !             sky versions of these quantities.
    522 
    523       if (top_height .eq. 1 .or. top_height .eq. 3) then
    524 
    525 
    526         !----------------------------------------------------------------------
    527         !   
    528         !             DO CLEAR SKY RADIANCE CALCULATION FIRST
    529         !
    530         !compute water vapor continuum emissivity
    531         !this treatment follows Schwarkzopf and Ramasamy
    532         !JGR 1999,vol 104, pages 9467-9499.
    533         !the emissivity is calculated at a wavenumber of 955 cm-1,
    534         !or 10.47 microns
    535         wtmair = 28.9644
    536         wtmh20 = 18.01534
    537         Navo = 6.023E+23
    538         grav = 9.806650E+02
    539         pstd = 1.013250E+06
    540         t0 = 296.
    541         if (ncolprint .ne. 0)
    542      &         write(6,*)  'ilev   pw (kg/m2)   tauwv(j)      dem_wv'
    543         do 125 ilev=1,nlev
    544           do j=1,npoints
    545                !press and dpress are dyne/cm2 = Pascals *10
    546                press(j) = pfull(j,ilev)*10.
    547                dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10
    548                !atmden = g/cm2 = kg/m2 / 10
    549                atmden(j) = dpress(j)/grav
    550                rvh20(j) = qv(j,ilev)*wtmair/wtmh20
    551                wk(j) = rvh20(j)*Navo*atmden(j)/wtmair
    552                rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev))
    553                rh20s(j) = rvh20(j)*rhoave(j)
    554                rfrgn(j) = rhoave(j)-rh20s(j)
    555                tmpexp(j) = exp(-0.02*(at(j,ilev)-t0))
    556                tauwv(j) = wk(j)*1.e-20*(
    557      &           (0.0224697*rh20s(j)*tmpexp(j)) +
    558      &                (3.41817e-7*rfrgn(j)) )*0.98
    559                dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j))
    560           enddo
    561                if (ncolprint .ne. 0) then
    562                do j=1,npoints ,1000
    563                write(6,'(a10)') 'j='
    564                write(6,'(8I10)') j
    565                write(6,'(i2,1X,3(f8.3,3X))') ilev,
    566      &           qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.),
    567      &           tauwv(j),dem_wv(j,ilev)
    568                enddo
    569              endif
    570 125     continue
    571 
    572         !initialize variables
    573         do j=1,npoints
    574           fluxtop_clrsky(j) = 0.
    575           trans_layers_above_clrsky(j)=1.
    576         enddo
    577 
     1091
     1092      endif
     1093
     1094      if (sunlit(j).eq.1 .or. top_height .eq. 3) then
     1095
     1096       if (box_cloudy(j,ibox)) then
     1097
     1098          ! !convert ptop to millibars
     1099          ptop(j,ibox)=ptop(j,ibox) / 100.
     1100
     1101          ! !save for output cloud top pressure and optical thickness
     1102          boxptop(j,ibox) = ptop(j,ibox)
     1103
     1104          if (tau(j,ibox) .ge. isccp_taumin) then
     1105            meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
     1106          end if
     1107
     1108          ! !reset itau(j), ipres(j)
     1109          itau(j) = 0
     1110          ipres(j) = 0
     1111
     1112          ! !determine optical depth category
     1113          if (tau(j,ibox) .lt. isccp_taumin) then
     1114              itau(j)=1
     1115          else if (tau(j,ibox) .ge. isccp_taumin &
     1116   &
     1117                .and. tau(j,ibox) .lt. 1.3) then
     1118            itau(j)=2
     1119          else if (tau(j,ibox) .ge. 1.3 &
     1120                .and. tau(j,ibox) .lt. 3.6) then
     1121            itau(j)=3
     1122          else if (tau(j,ibox) .ge. 3.6 &
     1123                .and. tau(j,ibox) .lt. 9.4) then
     1124              itau(j)=4
     1125          else if (tau(j,ibox) .ge. 9.4 &
     1126                .and. tau(j,ibox) .lt. 23.) then
     1127              itau(j)=5
     1128          else if (tau(j,ibox) .ge. 23. &
     1129                .and. tau(j,ibox) .lt. 60.) then
     1130              itau(j)=6
     1131          else if (tau(j,ibox) .ge. 60.) then
     1132              itau(j)=7
     1133          end if
     1134
     1135          ! !determine cloud top pressure category
     1136          if (    ptop(j,ibox) .gt. 0. &
     1137                .and.ptop(j,ibox) .lt. 180.) then
     1138              ipres(j)=1
     1139          else if(ptop(j,ibox) .ge. 180. &
     1140                .and.ptop(j,ibox) .lt. 310.) then
     1141              ipres(j)=2
     1142          else if(ptop(j,ibox) .ge. 310. &
     1143                .and.ptop(j,ibox) .lt. 440.) then
     1144              ipres(j)=3
     1145          else if(ptop(j,ibox) .ge. 440. &
     1146                .and.ptop(j,ibox) .lt. 560.) then
     1147              ipres(j)=4
     1148          else if(ptop(j,ibox) .ge. 560. &
     1149                .and.ptop(j,ibox) .lt. 680.) then
     1150              ipres(j)=5
     1151          else if(ptop(j,ibox) .ge. 680. &
     1152                .and.ptop(j,ibox) .lt. 800.) then
     1153              ipres(j)=6
     1154          else if(ptop(j,ibox) .ge. 800.) then
     1155              ipres(j)=7
     1156          end if
     1157
     1158          ! !update frequencies
     1159          if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then
     1160          fq_isccp(j,itau(j),ipres(j))= &
     1161                fq_isccp(j,itau(j),ipres(j))+ boxarea
     1162          end if
     1163
     1164        end if
     1165
     1166      end if
     1167
     1168    enddo ! j
     1169  end do
     1170
     1171  ! !compute mean cloud properties
     1172  do j=1,npoints
     1173    if (totalcldarea(j) .gt. 0.) then
     1174      ! code above guarantees that totalcldarea > 0
     1175      ! only if sunlit .eq. 1 .or. top_height = 3
     1176      ! and applies only to clouds with tau > isccp_taumin
     1177      meanptop(j) = meanptop(j) / totalcldarea(j)
     1178      meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
     1179      meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895)
     1180    else
     1181      ! this code is necessary so that in the case that totalcldarea = 0.,
     1182      ! that these variables, which are in-cloud averages, are set to missing
     1183      ! note that totalcldarea will be 0. if all the clouds in the grid box have
     1184      ! tau < isccp_taumin
     1185      meanptop(j) = output_missing_value
     1186      meanalbedocld(j) = output_missing_value
     1187      meantaucld(j) = output_missing_value
     1188    end if
     1189  enddo ! j
     1190  !
     1191  ! ---------------------------------------------------!
     1192
     1193  ! ---------------------------------------------------!
     1194  ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
     1195  !
     1196  if (debugcol.ne.0) then
     1197  !
     1198     do j=1,npoints,debugcol
     1199
     1200        ! !produce character output
    5781201        do ilev=1,nlev
    579           do j=1,npoints
    580  
    581             ! Black body emission at temperature of the layer
    582 
    583               bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
    584               !bb(j)= 5.67e-8*at(j,ilev)**4
    585 
    586               ! increase TOA flux by flux emitted from layer
    587               ! times total transmittance in layers above
    588 
    589                 fluxtop_clrsky(j) = fluxtop_clrsky(j)
    590      &            + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j)
    591            
    592                 ! update trans_layers_above with transmissivity
    593               ! from this layer for next time around loop
    594 
    595                 trans_layers_above_clrsky(j)=
    596      &            trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev))
    597                    
    598 
    599           enddo   
    600             if (ncolprint.ne.0) then
    601              do j=1,npoints ,1000
    602               write(6,'(a10)') 'j='
    603               write(6,'(8I10)') j
    604               write (6,'(a)') 'ilev:'
    605               write (6,'(I2)') ilev
    606    
    607               write (6,'(a)')
    608      &        'emiss_layer,100.*bb(j),100.*f,total_trans:'
    609               write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j),
    610      &             100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
    611              enddo   
    612             endif
    613 
    614         enddo   !loop over level
    615        
    616         do j=1,npoints
    617           !add in surface emission
    618           bb(j)=1/( exp(1307.27/skt(j)) - 1. )
    619           !bb(j)=5.67e-8*skt(j)**4
    620 
    621           fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j)
    622      &     * trans_layers_above_clrsky(j)
    623      
    624           !clear sky brightness temperature
    625           meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
    626          
    627         enddo
    628 
    629         if (ncolprint.ne.0) then
    630         do j=1,npoints ,1000
    631           write(6,'(a10)') 'j='
    632           write(6,'(8I10)') j
    633           write (6,'(a)') 'id:'
    634           write (6,'(a)') 'surface'
    635 
    636           write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
    637           write (6,'(5(f7.2,1X))') emsfc_lw,100.*bb(j),
    638      &      100.*fluxtop_clrsky(j),
    639      &       trans_layers_above_clrsky(j), meantbclr(j)
    640         enddo
    641       endif
    642    
    643 
    644         !
    645         !           END OF CLEAR SKY CALCULATION
    646         !
    647         !----------------------------------------------------------------
    648 
    649 
    650 
    651         if (ncolprint.ne.0) then
    652 
    653         do j=1,npoints ,1000
    654             write(6,'(a10)') 'j='
    655             write(6,'(8I10)') j
    656             write (6,'(a)') 'ts:'
    657             write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)
    658    
    659             write (6,'(a)') 'ta_rev:'
    660             write (6,'(8f7.2)')
    661      &       ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
    662 
    663         enddo
    664         endif
    665         !loop over columns
    666         do ibox=1,ncol
    667           do j=1,npoints
    668             fluxtop(j,ibox)=0.
    669             trans_layers_above(j,ibox)=1.
     1202          do ibox=1,ncol
     1203               acc(ilev,ibox)=0
    6701204          enddo
    6711205        enddo
    6721206
    6731207        do ilev=1,nlev
    674               do j=1,npoints
    675                 ! Black body emission at temperature of the layer
    676 
    677               bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
    678               !bb(j)= 5.67e-8*at(j,ilev)**4
    679               enddo
    680 
    681             do ibox=1,ncol
    682               do j=1,npoints
    683 
    684               ! emissivity for point in this layer
    685                 if (frac_out(j,ibox,ilev).eq.1) then
    686                 dem(j,ibox)= 1. -
    687      &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_s(j,ilev)) )
    688                 else if (frac_out(j,ibox,ilev).eq.2) then
    689                 dem(j,ibox)= 1. -
    690      &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_c(j,ilev)) )
    691                 else
    692                 dem(j,ibox)=  dem_wv(j,ilev)
    693                 end if
    694                
    695 
    696                 ! increase TOA flux by flux emitted from layer
    697               ! times total transmittance in layers above
    698 
    699                 fluxtop(j,ibox) = fluxtop(j,ibox)
    700      &            + dem(j,ibox) * bb(j)
    701      &            * trans_layers_above(j,ibox)
    702            
    703                 ! update trans_layers_above with transmissivity
    704               ! from this layer for next time around loop
    705 
    706                 trans_layers_above(j,ibox)=
    707      &            trans_layers_above(j,ibox)*(1.-dem(j,ibox))
    708 
    709               enddo ! j
    710             enddo ! ibox
    711 
    712             if (ncolprint.ne.0) then
    713               do j=1,npoints,1000
    714               write (6,'(a)') 'ilev:'
    715               write (6,'(I2)') ilev
    716    
    717               write(6,'(a10)') 'j='
    718               write(6,'(8I10)') j
    719               write (6,'(a)') 'emiss_layer:'
    720               write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
    721        
    722               write (6,'(a)') '100.*bb(j):'
    723               write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
    724        
    725               write (6,'(a)') '100.*f:'
    726               write (6,'(8f7.2)')
    727      &         (100.*fluxtop(j,ibox),ibox=1,ncolprint)
    728        
    729               write (6,'(a)') 'total_trans:'
    730               write (6,'(8f7.2)')
    731      &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
    732             enddo
    733           endif
    734 
    735         enddo ! ilev
    736 
    737 
    738           do j=1,npoints
    739             !add in surface emission
    740             bb(j)=1/( exp(1307.27/skt(j)) - 1. )
    741             !bb(j)=5.67e-8*skt(j)**4
    742           end do
    743 
    744         do ibox=1,ncol
    745           do j=1,npoints
    746 
    747             !add in surface emission
    748 
    749             fluxtop(j,ibox) = fluxtop(j,ibox)
    750      &         + emsfc_lw * bb(j)
    751      &         * trans_layers_above(j,ibox)
    752            
    753           end do
    754         end do
    755 
    756         !calculate mean infrared brightness temperature
    757         do ibox=1,ncol
    758           do j=1,npoints
    759             meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox))))
    760           end do
    761         end do
    762           do j=1, npoints
    763             meantb(j) = meantb(j) / real(ncol)
    764           end do       
    765 
    766         if (ncolprint.ne.0) then
    767 
    768           do j=1,npoints ,1000
    769           write(6,'(a10)') 'j='
    770           write(6,'(8I10)') j
    771           write (6,'(a)') 'id:'
    772           write (6,'(a)') 'surface'
    773 
    774           write (6,'(a)') 'emiss_layer:'
    775           write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
    776    
    777           write (6,'(a)') '100.*bb(j):'
    778           write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
    779    
    780           write (6,'(a)') '100.*f:'
    781           write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
    782          
    783           write (6,'(a)') 'meantb(j):'
    784           write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint)
    785      
    786           end do
    787       endif
    788    
    789         !now that you have the top of atmosphere radiance account
    790         !for ISCCP procedures to determine cloud top temperature
    791 
    792         !account for partially transmitting cloud recompute flux
    793         !ISCCP would see assuming a single layer cloud
    794         !note choice here of 2.13, as it is primarily ice
    795         !clouds which have partial emissivity and need the
    796         !adjustment performed in this section
    797         !
    798       !If it turns out that the cloud brightness temperature
    799       !is greater than 260K, then the liquid cloud conversion
    800         !factor of 2.56 is used.
    801       !
    802         !Note that this is discussed on pages 85-87 of
    803         !the ISCCP D level documentation (Rossow et al. 1996)
    804            
    805           do j=1,npoints 
    806             !compute minimum brightness temperature and optical depth
    807             btcmin(j) = 1. /  ( exp(1307.27/(attrop(j)-5.)) - 1. )
    808           enddo
    809         do ibox=1,ncol
    810           do j=1,npoints 
    811             transmax(j) = (fluxtop(j,ibox)-btcmin(j))
    812      &                /(fluxtop_clrsky(j)-btcmin(j))
    813           !note that the initial setting of tauir(j) is needed so that
    814           !tauir(j) has a realistic value should the next if block be
    815           !bypassed
    816             tauir(j) = tau(j,ibox) * rec2p13
    817             taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001))
    818 
    819           enddo
    820 
    821           if (top_height .eq. 1) then
    822             do j=1,npoints 
    823               if (transmax(j) .gt. 0.001 .and.
    824      &          transmax(j) .le. 0.9999999) then
    825                 fluxtopinit(j) = fluxtop(j,ibox)
    826               tauir(j) = tau(j,ibox) *rec2p13
    827               endif
    828             enddo
    829             do icycle=1,2
    830               do j=1,npoints 
    831                 if (tau(j,ibox) .gt. (tauchk            )) then
    832                 if (transmax(j) .gt. 0.001 .and.
    833      &            transmax(j) .le. 0.9999999) then
    834                   emcld(j,ibox) = 1. - exp(-1. * tauir(j)  )
    835                   fluxtop(j,ibox) = fluxtopinit(j) -   
    836      &              ((1.-emcld(j,ibox))*fluxtop_clrsky(j))
    837                   fluxtop(j,ibox)=max(1.E-06,
    838      &              (fluxtop(j,ibox)/emcld(j,ibox)))
    839                   tb(j,ibox)= 1307.27
    840      &              / (log(1. + (1./fluxtop(j,ibox))))
    841                   if (tb(j,ibox) .gt. 260.) then
    842                   tauir(j) = tau(j,ibox) / 2.56
    843                   end if                   
    844                 end if
    845                 end if
    846               enddo
    847             enddo
    848                
    849           endif
    850        
    851           do j=1,npoints
    852             if (tau(j,ibox) .gt. (tauchk            )) then
    853                 !cloudy box
    854                 !NOTE: tb is the cloud-top temperature not infrared brightness temperature
    855                 !at this point in the code
    856                 tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox))))
    857                 if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then
    858                          tb(j,ibox) = attrop(j) - 5.
    859                    tau(j,ibox) = 2.13*taumin(j)
    860                 end if
    861             else
    862                 !clear sky brightness temperature
    863                 tb(j,ibox) = meantbclr(j)
    864             end if
    865           enddo ! j
    866         enddo ! ibox
    867 
    868         if (ncolprint.ne.0) then
    869 
    870           do j=1,npoints,1000
    871           write(6,'(a10)') 'j='
    872           write(6,'(8I10)') j
    873 
    874           write (6,'(a)') 'attrop:'
    875           write (6,'(8f7.2)') (attrop(j))
    876    
    877           write (6,'(a)') 'btcmin:'
    878           write (6,'(8f7.2)') (btcmin(j))
    879    
    880           write (6,'(a)') 'fluxtop_clrsky*100:'
    881           write (6,'(8f7.2)')
    882      &      (100.*fluxtop_clrsky(j))
    883 
    884           write (6,'(a)') '100.*f_adj:'
    885           write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
    886    
    887           write (6,'(a)') 'transmax:'
    888           write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
    889    
    890           write (6,'(a)') 'tau:'
    891           write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
    892    
    893           write (6,'(a)') 'emcld:'
    894           write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
    895    
    896           write (6,'(a)') 'total_trans:'
    897           write (6,'(8f7.2)')
    898      &        (trans_layers_above(j,ibox),ibox=1,ncolprint)
    899    
    900           write (6,'(a)') 'total_emiss:'
    901           write (6,'(8f7.2)')
    902      &        (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
    903    
    904           write (6,'(a)') 'total_trans:'
    905           write (6,'(8f7.2)')
    906      &        (trans_layers_above(j,ibox),ibox=1,ncolprint)
    907    
    908           write (6,'(a)') 'ppout:'
    909           write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
    910           enddo ! j
    911       endif
    912 
    913       end if
    914 
    915 !     ---------------------------------------------------!
    916 
    917 !     
    918 !     ---------------------------------------------------!
    919 !     DETERMINE CLOUD TOP PRESSURE
    920 !
    921 !     again the 2 methods differ according to whether
    922 !     or not you use the physical cloud top pressure (top_height = 2)
    923 !     or the radiatively determined cloud top pressure (top_height = 1 or 3)
    924 !
    925 
    926       !compute cloud top pressure
    927       do 30 ibox=1,ncol
    928         !segregate according to optical thickness
    929         if (top_height .eq. 1 .or. top_height .eq. 3) then 
    930           !find level whose temperature
    931           !most closely matches brightness temperature
    932           do j=1,npoints
    933             nmatch(j)=0
     1208          do ibox=1,ncol
     1209               acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
     1210               if (levmatch(j,ibox) .eq. ilev) &
     1211                     acc(ilev,ibox)=acc(ilev,ibox)+1
    9341212          enddo
    935           do 29 k1=1,nlev-1
    936             if (top_height_direction .eq. 2) then
    937               ilev = nlev - k1
    938             else
    939               ilev = k1
    940             end if
    941             !cdir nodep
    942             do j=1,npoints
    943              if (ilev .ge. itrop(j)) then
    944               if ((at(j,ilev)   .ge. tb(j,ibox) .and.
    945      &          at(j,ilev+1) .le. tb(j,ibox)) .or.
    946      &          (at(j,ilev) .le. tb(j,ibox) .and.
    947      &          at(j,ilev+1) .ge. tb(j,ibox))) then
    948                 nmatch(j)=nmatch(j)+1
    949                 match(j,nmatch(j))=ilev
    950               end if 
    951              end if                         
    952             enddo
    953 29        continue
    954 
    955           do j=1,npoints
    956             if (nmatch(j) .ge. 1) then
    957               k1 = match(j,nmatch(j))
    958               k2 = k1 + 1
    959               logp1 = log(pfull(j,k1))
    960               logp2 = log(pfull(j,k2))
    961               atd = max(tauchk,abs(at(j,k2) - at(j,k1)))
    962               logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd
    963               ptop(j,ibox) = exp(logp)
    964               if(abs(pfull(j,k1)-ptop(j,ibox)) .lt.
    965      &            abs(pfull(j,k2)-ptop(j,ibox))) then
    966                  levmatch(j,ibox)=k1
    967               else
    968                  levmatch(j,ibox)=k2
    969               end if   
    970             else
    971               if (tb(j,ibox) .le. attrop(j)) then
    972                 ptop(j,ibox)=ptrop(j)
    973                 levmatch(j,ibox)=itrop(j)
    974               end if
    975               if (tb(j,ibox) .ge. atmax(j)) then
    976                 ptop(j,ibox)=pfull(j,nlev)
    977                 levmatch(j,ibox)=nlev
    978               end if                               
    979             end if
    980           enddo ! j
    981 
    982         else ! if (top_height .eq. 1 .or. top_height .eq. 3)
    983  
    984           do j=1,npoints     
    985             ptop(j,ibox)=0.
    986           enddo
    987           do ilev=1,nlev
    988             do j=1,npoints     
    989               if ((ptop(j,ibox) .eq. 0. )
    990      &           .and.(frac_out(j,ibox,ilev) .ne. 0)) then
    991                 ptop(j,ibox)=phalf(j,ilev)
    992               levmatch(j,ibox)=ilev
    993               end if
    994             end do
    995           end do
    996         end if                           
    997          
    998         do j=1,npoints
    999           if (tau(j,ibox) .le. (tauchk            )) then
    1000             ptop(j,ibox)=0.
    1001             levmatch(j,ibox)=0     
    1002           endif
    10031213        enddo
    10041214
    1005 30    continue
    1006              
    1007 !
    1008 !
    1009 !     ---------------------------------------------------!
    1010 
    1011 
    1012 !     
    1013 !     ---------------------------------------------------!
    1014 !     DETERMINE ISCCP CLOUD TYPE FREQUENCIES
    1015 !
    1016 !     Now that ptop and tau have been determined,
    1017 !     determine amount of each of the 49 ISCCP cloud
    1018 !     types
    1019 !
    1020 !     Also compute grid box mean cloud top pressure and
    1021 !     optical thickness.  The mean cloud top pressure and
    1022 !     optical thickness are averages over the cloudy
    1023 !     area only. The mean cloud top pressure is a linear
    1024 !     average of the cloud top pressures.  The mean cloud
    1025 !     optical thickness is computed by converting optical
    1026 !     thickness to an albedo, averaging in albedo units,
    1027 !     then converting the average albedo back to a mean
    1028 !     optical thickness. 
    1029 !
    1030 
    1031       !compute isccp frequencies
    1032 
    1033       !reset frequencies
    1034       do 38 ilev=1,7
    1035       do 38 ilev2=1,7
    1036         do j=1,npoints !
    1037              if (sunlit(j).eq.1 .or. top_height .eq. 3) then
    1038                 fq_isccp(j,ilev,ilev2)= 0.
    1039              else
    1040                 fq_isccp(j,ilev,ilev2)= output_missing_value
    1041              end if
    1042         enddo
    1043 38    continue
    1044 
    1045       !reset variables need for averaging cloud properties
    1046       do j=1,npoints
    1047         if (sunlit(j).eq.1 .or. top_height .eq. 3) then
    1048              totalcldarea(j) = 0.
    1049              meanalbedocld(j) = 0.
    1050              meanptop(j) = 0.
    1051              meantaucld(j) = 0.
    1052         else
    1053              totalcldarea(j) = output_missing_value
    1054              meanalbedocld(j) = output_missing_value
    1055              meanptop(j) = output_missing_value
    1056              meantaucld(j) = output_missing_value
    1057         end if
    1058       enddo ! j
    1059 
    1060       boxarea = 1./real(ncol)
    1061      
    1062       do 39 ibox=1,ncol
    1063         do j=1,npoints
    1064 
    1065           if (tau(j,ibox) .gt. (tauchk            )
    1066      &      .and. ptop(j,ibox) .gt. 0.) then
    1067               box_cloudy(j,ibox)=.true.
    1068           endif
    1069 
    1070           if (box_cloudy(j,ibox)) then
    1071 
    1072               if (sunlit(j).eq.1 .or. top_height .eq. 3) then
    1073 
    1074                 boxtau(j,ibox) = tau(j,ibox)
    1075 
    1076                 if (tau(j,ibox) .ge. isccp_taumin) then
    1077                    totalcldarea(j) = totalcldarea(j) + boxarea
    1078                
    1079                    !convert optical thickness to albedo
    1080                    albedocld(j,ibox)
    1081      &             = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82)
    1082          
    1083                    !contribute to averaging
    1084                    meanalbedocld(j) = meanalbedocld(j)
    1085      &                                +albedocld(j,ibox)*boxarea
    1086 
    1087                 end if
    1088 
    1089             endif
    1090 
    1091           endif
    1092 
    1093           if (sunlit(j).eq.1 .or. top_height .eq. 3) then
    1094 
    1095            if (box_cloudy(j,ibox)) then
    1096          
    1097               !convert ptop to millibars
    1098               ptop(j,ibox)=ptop(j,ibox) / 100.
    1099            
    1100               !save for output cloud top pressure and optical thickness
    1101               boxptop(j,ibox) = ptop(j,ibox)
    1102    
    1103               if (tau(j,ibox) .ge. isccp_taumin) then
    1104                 meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
    1105               end if           
    1106 
    1107               !reset itau(j), ipres(j)
    1108               itau(j) = 0
    1109               ipres(j) = 0
    1110 
    1111               !determine optical depth category
    1112               if (tau(j,ibox) .lt. isccp_taumin) then
    1113                   itau(j)=1
    1114               else if (tau(j,ibox) .ge. isccp_taumin
    1115      &                                   
    1116      &          .and. tau(j,ibox) .lt. 1.3) then
    1117                 itau(j)=2
    1118               else if (tau(j,ibox) .ge. 1.3
    1119      &          .and. tau(j,ibox) .lt. 3.6) then
    1120                 itau(j)=3
    1121               else if (tau(j,ibox) .ge. 3.6
    1122      &          .and. tau(j,ibox) .lt. 9.4) then
    1123                   itau(j)=4
    1124               else if (tau(j,ibox) .ge. 9.4
    1125      &          .and. tau(j,ibox) .lt. 23.) then
    1126                   itau(j)=5
    1127               else if (tau(j,ibox) .ge. 23.
    1128      &          .and. tau(j,ibox) .lt. 60.) then
    1129                   itau(j)=6
    1130               else if (tau(j,ibox) .ge. 60.) then
    1131                   itau(j)=7
    1132               end if
    1133 
    1134               !determine cloud top pressure category
    1135               if (    ptop(j,ibox) .gt. 0. 
    1136      &          .and.ptop(j,ibox) .lt. 180.) then
    1137                   ipres(j)=1
    1138               else if(ptop(j,ibox) .ge. 180.
    1139      &          .and.ptop(j,ibox) .lt. 310.) then
    1140                   ipres(j)=2
    1141               else if(ptop(j,ibox) .ge. 310.
    1142      &          .and.ptop(j,ibox) .lt. 440.) then
    1143                   ipres(j)=3
    1144               else if(ptop(j,ibox) .ge. 440.
    1145      &          .and.ptop(j,ibox) .lt. 560.) then
    1146                   ipres(j)=4
    1147               else if(ptop(j,ibox) .ge. 560.
    1148      &          .and.ptop(j,ibox) .lt. 680.) then
    1149                   ipres(j)=5
    1150               else if(ptop(j,ibox) .ge. 680.
    1151      &          .and.ptop(j,ibox) .lt. 800.) then
    1152                   ipres(j)=6
    1153               else if(ptop(j,ibox) .ge. 800.) then
    1154                   ipres(j)=7
    1155               end if
    1156 
    1157               !update frequencies
    1158               if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then
    1159               fq_isccp(j,itau(j),ipres(j))=
    1160      &          fq_isccp(j,itau(j),ipres(j))+ boxarea
    1161               end if
    1162 
    1163             end if
    1164 
    1165           end if
    1166                        
    1167         enddo ! j
    1168 39    continue
    1169      
    1170       !compute mean cloud properties
    1171       do j=1,npoints
    1172         if (totalcldarea(j) .gt. 0.) then
    1173           ! code above guarantees that totalcldarea > 0
    1174           ! only if sunlit .eq. 1 .or. top_height = 3
    1175           ! and applies only to clouds with tau > isccp_taumin
    1176           meanptop(j) = meanptop(j) / totalcldarea(j)
    1177           meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
    1178           meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895)
    1179         else
    1180           ! this code is necessary so that in the case that totalcldarea = 0.,
    1181           ! that these variables, which are in-cloud averages, are set to missing
    1182           ! note that totalcldarea will be 0. if all the clouds in the grid box have
    1183           ! tau < isccp_taumin
    1184           meanptop(j) = output_missing_value
    1185           meanalbedocld(j) = output_missing_value
    1186           meantaucld(j) = output_missing_value
    1187         end if
    1188       enddo ! j
    1189 !
    1190 !     ---------------------------------------------------!
    1191 
    1192 !     ---------------------------------------------------!
    1193 !     OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
    1194 !
    1195       if (debugcol.ne.0) then
    1196 !     
    1197          do j=1,npoints,debugcol
    1198 
    1199             !produce character output
    1200             do ilev=1,nlev
    1201               do ibox=1,ncol
    1202                    acc(ilev,ibox)=0
    1203               enddo
    1204             enddo
    1205 
    1206             do ilev=1,nlev
    1207               do ibox=1,ncol
    1208                    acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
    1209                    if (levmatch(j,ibox) .eq. ilev)
    1210      &                 acc(ilev,ibox)=acc(ilev,ibox)+1
    1211               enddo
    1212             enddo
    1213 
    1214              !print test
    1215 
    1216           write(ftn09,11) j
    1217 11        format('ftn09.',i4.4)
    1218           open(9, FILE=ftn09, FORM='FORMATTED')
    1219 
    1220              write(9,'(a1)') ' '
    1221              write(9,'(10i5)')
    1222      &                  (ilev,ilev=5,nlev,5)
    1223              write(9,'(a1)') ' '
    1224              
    1225              do ibox=1,ncol
    1226                write(9,'(40(a1),1x,40(a1))')
    1227      &           (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev)
    1228      &           ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev)
    1229              end do
    1230              close(9)
    1231 
    1232              if (ncolprint.ne.0) then
    1233                write(6,'(a1)') ' '
    1234                     write(6,'(a2,1X,5(a7,1X),a50)')
    1235      &                  'ilev',
    1236      &                  'pfull','at',
    1237      &                  'cc*100','dem_s','dtau_s',
    1238      &                  'cchar'
    1239 
    1240 !               do 4012 ilev=1,nlev
    1241 !                    write(6,'(60i2)') (box(i,ilev),i=1,ncolprint)
    1242 !                   write(6,'(i2,1X,5(f7.2,1X),50(a1))')
    1243 !     &                  ilev,
    1244 !     &                  pfull(j,ilev)/100.,at(j,ilev),
    1245 !     &                  cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev)
    1246 !     &                  ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint)
    1247 !4012           continue
    1248                write (6,'(a)') 'skt(j):'
    1249                write (6,'(8f7.2)') skt(j)
    1250                                      
    1251                write (6,'(8I7)') (ibox,ibox=1,ncolprint)
    1252            
    1253                write (6,'(a)') 'tau:'
    1254                write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
    1255    
    1256                write (6,'(a)') 'tb:'
    1257                write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
    1258    
    1259                write (6,'(a)') 'ptop:'
    1260                write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
    1261              endif
    1262    
    1263         enddo
    1264        
    1265       end if
    1266 
    1267       return
    1268       end
    1269 
    1270 
     1215         ! !print test
     1216
     1217      write(ftn09,11) j
     121811     format('ftn09.',i4.4)
     1219      open(9, FILE=ftn09, FORM='FORMATTED')
     1220
     1221         write(9,'(a1)') ' '
     1222         write(9,'(10i5)') &
     1223               (ilev,ilev=5,nlev,5)
     1224         write(9,'(a1)') ' '
     1225
     1226         do ibox=1,ncol
     1227           write(9,'(40(a1),1x,40(a1))') &
     1228                 (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) &
     1229                 ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev)
     1230         end do
     1231         close(9)
     1232
     1233         if (ncolprint.ne.0) then
     1234           write(6,'(a1)') ' '
     1235                write(6,'(a2,1X,5(a7,1X),a50)') &
     1236                      'ilev', &
     1237                      'pfull','at', &
     1238                      'cc*100','dem_s','dtau_s', &
     1239                      'cchar'
     1240
     1241            ! do 4012 ilev=1,nlev
     1242            !      write(6,'(60i2)') (box(i,ilev),i=1,ncolprint)
     1243            !     write(6,'(i2,1X,5(f7.2,1X),50(a1))')
     1244  ! &                  ilev,
     1245  ! &                  pfull(j,ilev)/100.,at(j,ilev),
     1246  ! &                  cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev)
     1247  ! &                  ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint)
     1248  !4012           continue
     1249           write (6,'(a)') 'skt(j):'
     1250           write (6,'(8f7.2)') skt(j)
     1251
     1252           write (6,'(8I7)') (ibox,ibox=1,ncolprint)
     1253
     1254           write (6,'(a)') 'tau:'
     1255           write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
     1256
     1257           write (6,'(a)') 'tb:'
     1258           write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
     1259
     1260           write (6,'(a)') 'ptop:'
     1261           write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
     1262         endif
     1263
     1264    enddo
     1265
     1266  end if
     1267
     1268  return
     1269end subroutine icarus
     1270
     1271
  • LMDZ6/trunk/libf/phylmd/cosp/isccp_cloud_types.f90

    r5247 r5248  
    11! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
    22! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/isccp_cloud_types.f $
    3       SUBROUTINE ISCCP_CLOUD_TYPES(
    4      &     debug,
    5      &     debugcol,
    6      &     npoints,
    7      &     sunlit,
    8      &     nlev,
    9      &     ncol,
    10      &     seed,
    11      &     pfull,
    12      &     phalf,
    13      &     qv,
    14      &     cc,
    15      &     conv,
    16      &     dtau_s,
    17      &     dtau_c,
    18      &     top_height,
    19      &     top_height_direction,
    20      &     overlap,
    21      &     frac_out,
    22      &     skt,
    23      &     emsfc_lw,
    24      &     at,
    25      &     dem_s,
    26      &     dem_c,
    27      &     fq_isccp,
    28      &     totalcldarea,
    29      &     meanptop,
    30      &     meantaucld,
    31      &     meanalbedocld,
    32      &     meantb,
    33      &     meantbclr,
    34      &     boxtau,
    35      &     boxptop
    36      &)
    37 
    38 !$Id: isccp_cloud_types.f,v 4.0 2009/03/06 11:05:11 hadmw Exp $
    39 
    40 ! *****************************COPYRIGHT****************************
    41 ! (c) British Crown Copyright 2009, the Met Office.
    42 ! All rights reserved.
    43 !
    44 ! Redistribution and use in source and binary forms, with or without
    45 ! modification, are permitted provided that the
    46 ! following conditions are met:
    47 !
    48 !     * Redistributions of source code must retain the above
    49 !       copyright  notice, this list of conditions and the following
    50 !       disclaimer.
    51 !     * Redistributions in binary form must reproduce the above
    52 !       copyright notice, this list of conditions and the following
    53 !       disclaimer in the documentation and/or other materials
    54 !       provided with the distribution.
    55 !     * Neither the name of the Met Office nor the names of its
    56 !       contributors may be used to endorse or promote products
    57 !       derived from this software without specific prior written
    58 !       permission.
    59 !
    60 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    61 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    62 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
    63 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
    64 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    65 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
    66 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
    67 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
    68 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
    69 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
    70 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 
    71 !
    72 ! *****************************COPYRIGHT*******************************
    73 ! *****************************COPYRIGHT*******************************
    74 ! *****************************COPYRIGHT*******************************
    75 
    76       implicit none
    77 
    78 !    NOTE:   the maximum number of levels and columns is set by
    79 !             the following parameter statement
    80 
    81       INTEGER ncolprint
    82      
    83 !    -----
    84 !     Input
    85 !    -----
    86 
    87       INTEGER npoints       !  number of model points in the horizontal
    88       INTEGER nlev          !  number of model levels in column
    89       INTEGER ncol          !  number of subcolumns
    90 
    91       INTEGER sunlit(npoints) !  1 for day points, 0 for night time
    92 
    93       INTEGER seed(npoints)
    94       !  seed values for marsaglia  random number generator
    95       !  It is recommended that the seed is set
    96       !  to a different value for each model
    97       !  gridbox it is called on, as it is
    98       !  possible that the choice of the same
    99       !  seed value every time may introduce some
    100       !  statistical bias in the results, particularly
    101       !  for low values of NCOL.
    102 
    103       REAL pfull(npoints,nlev)
    104                        !  pressure of full model levels (Pascals)
    105                   !  pfull(npoints,1) is top level of model
    106                   !  pfull(npoints,nlev) is bot of model
    107 
    108       REAL phalf(npoints,nlev+1)
    109                   !  pressure of half model levels (Pascals)
    110                   !  phalf(npoints,1) is top of model
    111                   !  phalf(npoints,nlev+1) is the surface pressure
    112 
    113       REAL qv(npoints,nlev)
    114                   !  water vapor specific humidity (kg vapor/ kg air)
    115                   !         on full model levels
    116 
    117       REAL cc(npoints,nlev)   
    118                   !  input cloud cover in each model level (fraction)
    119                   !  NOTE:  This is the HORIZONTAL area of each
    120                   !         grid box covered by clouds
    121 
    122       REAL conv(npoints,nlev)
    123                   !  input convective cloud cover in each model
    124                   !   level (fraction)
    125                   !  NOTE:  This is the HORIZONTAL area of each
    126                   !         grid box covered by convective clouds
    127 
    128       REAL dtau_s(npoints,nlev)
    129                   !  mean 0.67 micron optical depth of stratiform
    130                 !  clouds in each model level
    131                   !  NOTE:  this the cloud optical depth of only the
    132                   !  cloudy part of the grid box, it is not weighted
    133                   !  with the 0 cloud optical depth of the clear
    134                   !         part of the grid box
    135 
    136       REAL dtau_c(npoints,nlev)
    137                   !  mean 0.67 micron optical depth of convective
    138                 !  clouds in each
    139                   !  model level.  Same note applies as in dtau_s.
    140 
    141       INTEGER overlap                   !  overlap type
    142                               !  1=max
    143                               !  2=rand
    144                               !  3=max/rand
    145 
    146       INTEGER top_height                !  1 = adjust top height using both a computed
    147                                         !  infrared brightness temperature and the visible
    148                               !  optical depth to adjust cloud top pressure. Note
    149                               !  that this calculation is most appropriate to compare
    150                               !  to ISCCP data during sunlit hours.
    151                                         !  2 = do not adjust top height, that is cloud top
    152                                         !  pressure is the actual cloud top pressure
    153                                         !  in the model
    154                               !  3 = adjust top height using only the computed
    155                               !  infrared brightness temperature. Note that this
    156                               !  calculation is most appropriate to compare to ISCCP
    157                               !  IR only algortihm (i.e. you can compare to nighttime
    158                               !  ISCCP data with this option)
    159 
    160       INTEGER top_height_direction ! direction for finding atmosphere pressure level
    161                                  ! with interpolated temperature equal to the radiance
    162                                 ! determined cloud-top temperature
    163                                 !
    164                                 ! 1 = find the *lowest* altitude (highest pressure) level
    165                                 ! with interpolated temperature equal to the radiance
    166                                 ! determined cloud-top temperature
    167                                 !
    168                                 ! 2 = find the *highest* altitude (lowest pressure) level
    169                                  ! with interpolated temperature equal to the radiance
    170                                 ! determined cloud-top temperature
    171                                  !
    172                                 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
    173                                 !
    174                                  ! 1 = old setting: matches all versions of
    175                                 ! ISCCP simulator with versions numbers 3.5.1 and lower
    176                                 !
    177                                  ! 2 = default setting: for version numbers 4.0 and higher 
    178 !
    179 !    The following input variables are used only if top_height = 1 or top_height = 3
    180 !
    181       REAL skt(npoints)                 !  skin Temperature (K)
    182       REAL emsfc_lw                     !  10.5 micron emissivity of surface (fraction)                                           
    183       REAL at(npoints,nlev)                   !  temperature in each model level (K)
    184       REAL dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
    185                               !  clouds in each
    186                                         !  model level.  Same note applies as in dtau_s.
    187       REAL dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
    188                               !  clouds in each
    189                                         !  model level.  Same note applies as in dtau_s.
    190 
    191       REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
    192                               ! Equivalent of BOX in original version, but
    193                               ! indexed by column then row, rather than
    194                               ! by row then column
    195 
    196 
    197 
    198 !    ------
    199 !    Output
    200 !    ------
    201 
    202       REAL fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
    203                                         !  each of the 49 ISCCP D level cloud types
    204 
    205       REAL totalcldarea(npoints)        !  the fraction of model grid box columns
    206                                         !  with cloud somewhere in them.  NOTE: This diagnostic
    207                                         ! does not count model clouds with tau < isccp_taumin
    208                               ! Thus this diagnostic does not equal the sum over all entries of fq_isccp.
    209                               ! However, this diagnostic does equal the sum over entries of fq_isccp with
    210                               ! itau = 2:7 (omitting itau = 1)
    211      
    212      
    213       ! The following three means are averages only over the cloudy areas with tau > isccp_taumin. 
    214       ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero.     
    215                              
    216       REAL meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
    217                                         !  in cloud top pressure.
    218                              
    219       REAL meantaucld(npoints)          !  mean optical thickness
    220                                         !  linear averaging in albedo performed.
    221      
    222       real meanalbedocld(npoints)        ! mean cloud albedo
    223                                         ! linear averaging in albedo performed
    224                                        
    225       real meantb(npoints)              ! mean all-sky 10.5 micron brightness temperature
    226      
    227       real meantbclr(npoints)           ! mean clear-sky 10.5 micron brightness temperature
    228      
    229       REAL boxtau(npoints,ncol)         !  optical thickness in each column
    230      
    231       REAL boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column
    232                              
    233                                                                                          
    234 !
    235 !    ------
    236 !    Working variables added when program updated to mimic Mark Webb's PV-Wave code
    237 !    ------
    238 
    239       REAL dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave
    240                               !  emissivity in part of
    241                               !  gridbox under consideration
    242 
    243       REAL ptrop(npoints)
    244       REAL attrop(npoints)
    245       REAL attropmin (npoints)
    246       REAL atmax(npoints)
    247       REAL atmin(npoints)
    248       REAL btcmin(npoints)
    249       REAL transmax(npoints)
    250 
    251       INTEGER i,j,ilev,ibox,itrop(npoints)
    252       INTEGER ipres(npoints)
    253       INTEGER itau(npoints),ilev2
    254       INTEGER acc(nlev,ncol)
    255       INTEGER match(npoints,nlev-1)
    256       INTEGER nmatch(npoints)
    257       INTEGER levmatch(npoints,ncol)
    258      
    259       !variables needed for water vapor continuum absorption
    260       real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
    261       real taumin(npoints)
    262       real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
    263       real press(npoints), dpress(npoints), atmden(npoints)
    264       real rvh20(npoints), wk(npoints), rhoave(npoints)
    265       real rh20s(npoints), rfrgn(npoints)
    266       real tmpexp(npoints),tauwv(npoints)
    267      
    268       character*1 cchar(6),cchar_realtops(6)
    269       integer icycle
    270       REAL tau(npoints,ncol)
    271       LOGICAL box_cloudy(npoints,ncol)
    272       REAL tb(npoints,ncol)
    273       REAL ptop(npoints,ncol)
    274       REAL emcld(npoints,ncol)
    275       REAL fluxtop(npoints,ncol)
    276       REAL trans_layers_above(npoints,ncol)
    277       real isccp_taumin,fluxtopinit(npoints),tauir(npoints)
    278       REAL albedocld(npoints,ncol)
    279       real boxarea
    280       integer debug       ! set to non-zero value to print out inputs
    281                     ! with step debug
    282       integer debugcol    ! set to non-zero value to print out column
    283                     ! decomposition with step debugcol
    284       integer rangevec(npoints),rangeerror
    285 
    286       integer index1(npoints),num1,jj,k1,k2
    287       real rec2p13,tauchk,logp,logp1,logp2,atd
    288 
    289       character*10 ftn09
    290      
    291       DATA isccp_taumin / 0.3 /
    292       DATA cchar / ' ','-','1','+','I','+'/
    293       DATA cchar_realtops / ' ',' ','1','1','I','I'/
    294 
    295 !    ------ End duplicate definitions common to wrapper routine
    296 
    297        ncolprint=0
    298 
    299       CALL SCOPS(
    300      &     npoints,
    301      &     nlev,
    302      &     ncol,
    303      &     seed,
    304      &     cc,
    305      &     conv,
    306      &     overlap,
    307      &     frac_out,
    308      &     ncolprint
    309      &)
    310 
    311       CALL ICARUS(
    312      &     debug,
    313      &     debugcol,
    314      &     npoints,
    315      &     sunlit,
    316      &     nlev,
    317      &     ncol,
    318      &     pfull,
    319      &     phalf,
    320      &     qv,
    321      &     cc,
    322      &     conv,
    323      &     dtau_s,
    324      &     dtau_c,
    325      &     top_height,
    326      &     top_height_direction,
    327      &     overlap,
    328      &     frac_out,
    329      &     skt,
    330      &     emsfc_lw,
    331      &     at,
    332      &     dem_s,
    333      &     dem_c,
    334      &     fq_isccp,
    335      &     totalcldarea,
    336      &     meanptop,
    337      &     meantaucld,
    338      &     meanalbedocld,
    339      &     meantb,
    340      &     meantbclr,
    341      &     boxtau,
    342      &     boxptop
    343      &)
    344 
    345       return
    346       end
    347 
     3SUBROUTINE ISCCP_CLOUD_TYPES( &
     4        debug, &
     5        debugcol, &
     6        npoints, &
     7        sunlit, &
     8        nlev, &
     9        ncol, &
     10        seed, &
     11        pfull, &
     12        phalf, &
     13        qv, &
     14        cc, &
     15        conv, &
     16        dtau_s, &
     17        dtau_c, &
     18        top_height, &
     19        top_height_direction, &
     20        overlap, &
     21        frac_out, &
     22        skt, &
     23        emsfc_lw, &
     24        at, &
     25        dem_s, &
     26        dem_c, &
     27        fq_isccp, &
     28        totalcldarea, &
     29        meanptop, &
     30        meantaucld, &
     31        meanalbedocld, &
     32        meantb, &
     33        meantbclr, &
     34        boxtau, &
     35        boxptop &
     36        )
     37
     38  !$Id: isccp_cloud_types.f,v 4.0 2009/03/06 11:05:11 hadmw Exp $
     39
     40  ! *****************************COPYRIGHT****************************
     41  ! (c) British Crown Copyright 2009, the Met Office.
     42  ! All rights reserved.
     43  !
     44  ! Redistribution and use in source and binary forms, with or without
     45  ! modification, are permitted provided that the
     46  ! following conditions are met:
     47  !
     48  ! * Redistributions of source code must retain the above
     49  !   copyright  notice, this list of conditions and the following
     50  !   disclaimer.
     51  ! * Redistributions in binary form must reproduce the above
     52  !   copyright notice, this list of conditions and the following
     53  !   disclaimer in the documentation and/or other materials
     54  !   provided with the distribution.
     55  ! * Neither the name of the Met Office nor the names of its
     56  !   contributors may be used to endorse or promote products
     57  !   derived from this software without specific prior written
     58  !   permission.
     59  !
     60  ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
     61  ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
     62  ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
     63  ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
     64  ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
     65  ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
     66  ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
     67  ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
     68  ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
     69  ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
     70  ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     71  !
     72  ! *****************************COPYRIGHT*******************************
     73  ! *****************************COPYRIGHT*******************************
     74  ! *****************************COPYRIGHT*******************************
     75
     76  implicit none
     77
     78  ! NOTE:   the maximum number of levels and columns is set by
     79  !         the following parameter statement
     80
     81  INTEGER :: ncolprint
     82
     83  ! -----
     84  ! Input
     85  ! -----
     86
     87  INTEGER :: npoints       !  number of model points in the horizontal
     88  INTEGER :: nlev          !  number of model levels in column
     89  INTEGER :: ncol          !  number of subcolumns
     90
     91  INTEGER :: sunlit(npoints) !  1 for day points, 0 for night time
     92
     93  INTEGER :: seed(npoints)
     94  ! !  seed values for marsaglia  random number generator
     95  ! !  It is recommended that the seed is set
     96  ! !  to a different value for each model
     97  ! !  gridbox it is called on, as it is
     98  ! !  possible that the choice of the same
     99  ! !  seed value every time may introduce some
     100  ! !  statistical bias in the results, particularly
     101  ! !  for low values of NCOL.
     102
     103  REAL :: pfull(npoints,nlev)
     104                   ! !  pressure of full model levels (Pascals)
     105              ! !  pfull(npoints,1) is top level of model
     106              ! !  pfull(npoints,nlev) is bot of model
     107
     108  REAL :: phalf(npoints,nlev+1)
     109              ! !  pressure of half model levels (Pascals)
     110              ! !  phalf(npoints,1) is top of model
     111              ! !  phalf(npoints,nlev+1) is the surface pressure
     112
     113  REAL :: qv(npoints,nlev)
     114              ! !  water vapor specific humidity (kg vapor/ kg air)
     115              ! !         on full model levels
     116
     117  REAL :: cc(npoints,nlev)
     118              ! !  input cloud cover in each model level (fraction)
     119              ! !  NOTE:  This is the HORIZONTAL area of each
     120              ! !         grid box covered by clouds
     121
     122  REAL :: conv(npoints,nlev)
     123              ! !  input convective cloud cover in each model
     124              ! !   level (fraction)
     125              ! !  NOTE:  This is the HORIZONTAL area of each
     126              ! !         grid box covered by convective clouds
     127
     128  REAL :: dtau_s(npoints,nlev)
     129              ! !  mean 0.67 micron optical depth of stratiform
     130            ! !  clouds in each model level
     131            !   !  NOTE:  this the cloud optical depth of only the
     132            !   !  cloudy part of the grid box, it is not weighted
     133            !   !  with the 0 cloud optical depth of the clear
     134            !   !         part of the grid box
     135
     136  REAL :: dtau_c(npoints,nlev)
     137              ! !  mean 0.67 micron optical depth of convective
     138            ! !  clouds in each
     139            !   !  model level.  Same note applies as in dtau_s.
     140
     141  INTEGER :: overlap                   !  overlap type
     142                          ! !  1=max
     143                          ! !  2=rand
     144                          ! !  3=max/rand
     145
     146  INTEGER :: top_height                !  1 = adjust top height using both a computed
     147                                    ! !  infrared brightness temperature and the visible
     148                          ! !  optical depth to adjust cloud top pressure. Note
     149                          ! !  that this calculation is most appropriate to compare
     150                          ! !  to ISCCP data during sunlit hours.
     151                          !           !  2 = do not adjust top height, that is cloud top
     152                          !           !  pressure is the actual cloud top pressure
     153                          !           !  in the model
     154                          ! !  3 = adjust top height using only the computed
     155                          ! !  infrared brightness temperature. Note that this
     156                          ! !  calculation is most appropriate to compare to ISCCP
     157                          ! !  IR only algortihm (i.e. you can compare to nighttime
     158                          ! !  ISCCP data with this option)
     159
     160  INTEGER :: top_height_direction ! direction for finding atmosphere pressure level
     161                             ! ! with interpolated temperature equal to the radiance
     162                            ! determined cloud-top temperature
     163                            !
     164                            ! 1 = find the *lowest* altitude (highest pressure) level
     165                            ! with interpolated temperature equal to the radiance
     166                            ! determined cloud-top temperature
     167                            !
     168                            ! 2 = find the *highest* altitude (lowest pressure) level
     169                             ! with interpolated temperature equal to the radiance
     170                            ! determined cloud-top temperature
     171                             !
     172                            ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
     173                            !
     174                             ! 1 = old setting: matches all versions of
     175                            ! ISCCP simulator with versions numbers 3.5.1 and lower
     176                            !
     177                             ! 2 = default setting: for version numbers 4.0 and higher
     178  !
     179  ! The following input variables are used only if top_height = 1 or top_height = 3
     180  !
     181  REAL :: skt(npoints)                 !  skin Temperature (K)
     182  REAL :: emsfc_lw                     !  10.5 micron emissivity of surface (fraction)
     183  REAL :: at(npoints,nlev)                   !  temperature in each model level (K)
     184  REAL :: dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
     185                          ! !  clouds in each
     186                          !           !  model level.  Same note applies as in dtau_s.
     187  REAL :: dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
     188                          ! !  clouds in each
     189                          !           !  model level.  Same note applies as in dtau_s.
     190
     191  REAL :: frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
     192                          ! ! Equivalent of BOX in original version, but
     193                          ! ! indexed by column then row, rather than
     194                          ! ! by row then column
     195
     196
     197
     198  ! ------
     199  ! Output
     200  ! ------
     201
     202  REAL :: fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
     203                                    ! !  each of the 49 ISCCP D level cloud types
     204
     205  REAL :: totalcldarea(npoints)        !  the fraction of model grid box columns
     206                                    ! !  with cloud somewhere in them.  NOTE: This diagnostic
     207                                    ! does not count model clouds with tau < isccp_taumin
     208                          ! ! Thus this diagnostic does not equal the sum over all entries of fq_isccp.
     209                          ! However, this diagnostic does equal the sum over entries of fq_isccp with
     210                          ! itau = 2:7 (omitting itau = 1)
     211
     212
     213  ! ! The following three means are averages only over the cloudy areas with tau > isccp_taumin.
     214  ! ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero.
     215
     216  REAL :: meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
     217                                    ! !  in cloud top pressure.
     218
     219  REAL :: meantaucld(npoints)          !  mean optical thickness
     220                                    ! !  linear averaging in albedo performed.
     221
     222  real :: meanalbedocld(npoints)        ! mean cloud albedo
     223                                    ! ! linear averaging in albedo performed
     224
     225  real :: meantb(npoints)              ! mean all-sky 10.5 micron brightness temperature
     226
     227  real :: meantbclr(npoints)           ! mean clear-sky 10.5 micron brightness temperature
     228
     229  REAL :: boxtau(npoints,ncol)         !  optical thickness in each column
     230
     231  REAL :: boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column
     232
     233
     234  !
     235  ! ------
     236  ! Working variables added when program updated to mimic Mark Webb's PV-Wave code
     237  ! ------
     238
     239  REAL :: dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave
     240                          ! !  emissivity in part of
     241                          ! !  gridbox under consideration
     242
     243  REAL :: ptrop(npoints)
     244  REAL :: attrop(npoints)
     245  REAL :: attropmin (npoints)
     246  REAL :: atmax(npoints)
     247  REAL :: atmin(npoints)
     248  REAL :: btcmin(npoints)
     249  REAL :: transmax(npoints)
     250
     251  INTEGER :: i,j,ilev,ibox,itrop(npoints)
     252  INTEGER :: ipres(npoints)
     253  INTEGER :: itau(npoints),ilev2
     254  INTEGER :: acc(nlev,ncol)
     255  INTEGER :: match(npoints,nlev-1)
     256  INTEGER :: nmatch(npoints)
     257  INTEGER :: levmatch(npoints,ncol)
     258
     259  ! !variables needed for water vapor continuum absorption
     260  real :: fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
     261  real :: taumin(npoints)
     262  real :: dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
     263  real :: press(npoints), dpress(npoints), atmden(npoints)
     264  real :: rvh20(npoints), wk(npoints), rhoave(npoints)
     265  real :: rh20s(npoints), rfrgn(npoints)
     266  real :: tmpexp(npoints),tauwv(npoints)
     267
     268  character(len=1) :: cchar(6),cchar_realtops(6)
     269  integer :: icycle
     270  REAL :: tau(npoints,ncol)
     271  LOGICAL :: box_cloudy(npoints,ncol)
     272  REAL :: tb(npoints,ncol)
     273  REAL :: ptop(npoints,ncol)
     274  REAL :: emcld(npoints,ncol)
     275  REAL :: fluxtop(npoints,ncol)
     276  REAL :: trans_layers_above(npoints,ncol)
     277  real :: isccp_taumin,fluxtopinit(npoints),tauir(npoints)
     278  REAL :: albedocld(npoints,ncol)
     279  real :: boxarea
     280  integer :: debug       ! set to non-zero value to print out inputs
     281                ! ! with step debug
     282  integer :: debugcol    ! set to non-zero value to print out column
     283                ! ! decomposition with step debugcol
     284  integer :: rangevec(npoints),rangeerror
     285
     286  integer :: index1(npoints),num1,jj,k1,k2
     287  real :: rec2p13,tauchk,logp,logp1,logp2,atd
     288
     289  character(len=10) :: ftn09
     290
     291  DATA isccp_taumin / 0.3 /
     292  DATA cchar / ' ','-','1','+','I','+'/
     293  DATA cchar_realtops / ' ',' ','1','1','I','I'/
     294
     295  ! ------ End duplicate definitions common to wrapper routine
     296
     297   ncolprint=0
     298
     299  CALL SCOPS( &
     300        npoints, &
     301        nlev, &
     302        ncol, &
     303        seed, &
     304        cc, &
     305        conv, &
     306        overlap, &
     307        frac_out, &
     308        ncolprint &
     309        )
     310
     311  CALL ICARUS( &
     312        debug, &
     313        debugcol, &
     314        npoints, &
     315        sunlit, &
     316        nlev, &
     317        ncol, &
     318        pfull, &
     319        phalf, &
     320        qv, &
     321        cc, &
     322        conv, &
     323        dtau_s, &
     324        dtau_c, &
     325        top_height, &
     326        top_height_direction, &
     327        overlap, &
     328        frac_out, &
     329        skt, &
     330        emsfc_lw, &
     331        at, &
     332        dem_s, &
     333        dem_c, &
     334        fq_isccp, &
     335        totalcldarea, &
     336        meanptop, &
     337        meantaucld, &
     338        meanalbedocld, &
     339        meantb, &
     340        meantbclr, &
     341        boxtau, &
     342        boxptop &
     343        )
     344
     345  return
     346end subroutine isccp_cloud_types
     347
  • LMDZ6/trunk/libf/phylmd/cosp/pf_to_mr.f90

    r5247 r5248  
    33! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
    44! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/pf_to_mr.f $
    5 ! 
    6 ! Redistribution and use in source and binary forms, with or without modification, are permitted 
     5!
     6! Redistribution and use in source and binary forms, with or without modification, are permitted
    77! provided that the following conditions are met:
    8 ! 
    9 !     * Redistributions of source code must retain the above copyright notice, this list
    10 !       of conditions and the following disclaimer.
    11 !     * Redistributions in binary form must reproduce the above copyright notice, this list
    12 !       of conditions and the following disclaimer in the documentation and/or other materials
    13 !       provided with the distribution.
    14 !     * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation
    15 !       nor the names of its contributors may be used to endorse or promote products derived from
    16 !       this software without specific prior written permission.
    17 ! 
    18 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
    19 ! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
    20 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
    21 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
    22 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
    23 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
    24 ! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
     8!
     9! * Redistributions of source code must retain the above copyright notice, this list
     10!   of conditions and the following disclaimer.
     11! * Redistributions in binary form must reproduce the above copyright notice, this list
     12!   of conditions and the following disclaimer in the documentation and/or other materials
     13!   provided with the distribution.
     14! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation
     15!   nor the names of its contributors may be used to endorse or promote products derived from
     16!   this software without specific prior written permission.
     17!
     18! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
     19! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
     20! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
     21! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
     22! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
     23! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
     24! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
    2525! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    26      
    27       subroutine pf_to_mr(npoints,nlev,ncol,rain_ls,snow_ls,grpl_ls,
    28      &                    rain_cv,snow_cv,prec_frac,
    29      &                    p,t,mx_rain_ls,mx_snow_ls,mx_grpl_ls,
    30      &                    mx_rain_cv,mx_snow_cv)
     26
     27subroutine pf_to_mr(npoints,nlev,ncol,rain_ls,snow_ls,grpl_ls, &
     28        rain_cv,snow_cv,prec_frac, &
     29        p,t,mx_rain_ls,mx_snow_ls,mx_grpl_ls, &
     30        mx_rain_cv,mx_snow_cv)
    3131
    3232
    33       implicit none
     33  implicit none
    3434
    35       INTEGER npoints       !  number of model points in the horizontal
    36       INTEGER nlev          !  number of model levels in column
    37       INTEGER ncol          !  number of subcolumns
     35  INTEGER :: npoints       !  number of model points in the horizontal
     36  INTEGER :: nlev          !  number of model levels in column
     37  INTEGER :: ncol          !  number of subcolumns
    3838
    39       INTEGER j,ilev,ibox
    40      
    41       REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precip. flux
    42       REAL grpl_ls(npoints,nlev)
    43       REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precip. flux
     39  INTEGER :: j,ilev,ibox
    4440
    45       REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
    46                                         ! 1 -> LS precipitation
    47                                         ! 2 -> CONV precipitation
    48                                         ! 3 -> both
    49       REAL mx_rain_ls(npoints,ncol,nlev),mx_snow_ls(npoints,ncol,nlev)
    50       REAL mx_grpl_ls(npoints,ncol,nlev)
    51       REAL mx_rain_cv(npoints,ncol,nlev),mx_snow_cv(npoints,ncol,nlev)
    52       REAL p(npoints,nlev),t(npoints,nlev)
    53       REAL ar,as,ag,br,bs,bg,nr,ns,ng,rho0,rhor,rhos,rhog,rho
    54       REAL term1r,term1s,term1g,term2r,term2s,term2g,term3
    55       REAL term4r_ls,term4s_ls,term4g_ls,term4r_cv,term4s_cv
    56       REAL term1x2r,term1x2s,term1x2g,t123r,t123s,t123g
    57      
    58       ! method from Khairoutdinov and Randall (2003 JAS)
     41  REAL :: rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precip. flux
     42  REAL :: grpl_ls(npoints,nlev)
     43  REAL :: rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precip. flux
    5944
    60       ! --- List of constants from Appendix B
    61       ! Constant in fall speed formula
    62       ar=842.
    63       as=4.84
    64       ag=94.5
    65       ! Exponent in fall speed formula
    66       br=0.8
    67       bs=0.25
    68       bg=0.5
    69       ! Intercept parameter
    70       nr=8.*1000.*1000.
    71       ns=3.*1000.*1000.
    72       ng=4.*1000.*1000.
    73       ! Densities for air and hydrometeors
    74       rho0=1.29
    75       rhor=1000.
    76       rhos=100.
    77       rhog=400.
    78       ! Term 1 of Eq. (A19).
    79       term1r=ar*17.8379/6.
    80       term1s=as*8.28508/6.
    81       term1g=ag*11.6317/6.
    82       ! Term 2 of Eq. (A19).
    83       term2r=(3.14159265*rhor*nr)**(-br/4.)
    84       term2s=(3.14159265*rhos*ns)**(-bs/4.)
    85       term2g=(3.14159265*rhog*ng)**(-bg/4.)
    86      
    87       term1x2r=term1r*term2r
    88       term1x2s=term1s*term2s
    89       term1x2g=term1g*term2g
    90       do ilev=1,nlev
    91         do j=1,npoints
    92             rho=p(j,ilev)/(287.05*t(j,ilev))
    93             term3=(rho0/rho)**0.5
    94             ! Term 4 of Eq. (A19).
    95             t123r=term1x2r*term3
    96             t123s=term1x2s*term3
    97             t123g=term1x2g*term3
    98             term4r_ls=rain_ls(j,ilev)/(t123r)
    99             term4s_ls=snow_ls(j,ilev)/(t123s)
    100             term4g_ls=grpl_ls(j,ilev)/(t123g)
    101             term4r_cv=rain_cv(j,ilev)/(t123r)
    102             term4s_cv=snow_cv(j,ilev)/(t123s)
    103             do ibox=1,ncol
    104                 mx_rain_ls(j,ibox,ilev)=0.
    105                 mx_snow_ls(j,ibox,ilev)=0.
    106                 mx_grpl_ls(j,ibox,ilev)=0.
    107                 mx_rain_cv(j,ibox,ilev)=0.
    108                 mx_snow_cv(j,ibox,ilev)=0.
    109                 if ((prec_frac(j,ibox,ilev) .eq. 1.) .or.
    110      &              (prec_frac(j,ibox,ilev) .eq. 3.)) then
    111                     mx_rain_ls(j,ibox,ilev)=
    112      &                     (term4r_ls**(1./(1.+br/4.)))/rho
    113                     mx_snow_ls(j,ibox,ilev)=
    114      &                     (term4s_ls**(1./(1.+bs/4.)))/rho
    115                     mx_grpl_ls(j,ibox,ilev)=
    116      &                     (term4g_ls**(1./(1.+bg/4.)))/rho
    117                 endif
    118                 if ((prec_frac(j,ibox,ilev) .eq. 2.) .or.
    119      &              (prec_frac(j,ibox,ilev) .eq. 3.)) then
    120                     mx_rain_cv(j,ibox,ilev)=
    121      &                     (term4r_cv**(1./(1.+br/4.)))/rho
    122                     mx_snow_cv(j,ibox,ilev)=
    123      &                     (term4s_cv**(1./(1.+bs/4.)))/rho
    124                 endif
    125             enddo ! loop over ncol
    126         enddo ! loop over npoints
    127       enddo ! loop over nlev
    128  
    129       end
     45  REAL :: prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
     46                                    ! ! 1 -> LS precipitation
     47                                    ! ! 2 -> CONV precipitation
     48                                    ! ! 3 -> both
     49  REAL :: mx_rain_ls(npoints,ncol,nlev),mx_snow_ls(npoints,ncol,nlev)
     50  REAL :: mx_grpl_ls(npoints,ncol,nlev)
     51  REAL :: mx_rain_cv(npoints,ncol,nlev),mx_snow_cv(npoints,ncol,nlev)
     52  REAL :: p(npoints,nlev),t(npoints,nlev)
     53  REAL :: ar,as,ag,br,bs,bg,nr,ns,ng,rho0,rhor,rhos,rhog,rho
     54  REAL :: term1r,term1s,term1g,term2r,term2s,term2g,term3
     55  REAL :: term4r_ls,term4s_ls,term4g_ls,term4r_cv,term4s_cv
     56  REAL :: term1x2r,term1x2s,term1x2g,t123r,t123s,t123g
    13057
     58  ! ! method from Khairoutdinov and Randall (2003 JAS)
     59
     60  ! ! --- List of constants from Appendix B
     61  ! ! Constant in fall speed formula
     62  ar=842.
     63  as=4.84
     64  ag=94.5
     65  ! ! Exponent in fall speed formula
     66  br=0.8
     67  bs=0.25
     68  bg=0.5
     69  ! ! Intercept parameter
     70  nr=8.*1000.*1000.
     71  ns=3.*1000.*1000.
     72  ng=4.*1000.*1000.
     73  ! ! Densities for air and hydrometeors
     74  rho0=1.29
     75  rhor=1000.
     76  rhos=100.
     77  rhog=400.
     78  ! ! Term 1 of Eq. (A19).
     79  term1r=ar*17.8379/6.
     80  term1s=as*8.28508/6.
     81  term1g=ag*11.6317/6.
     82  ! ! Term 2 of Eq. (A19).
     83  term2r=(3.14159265*rhor*nr)**(-br/4.)
     84  term2s=(3.14159265*rhos*ns)**(-bs/4.)
     85  term2g=(3.14159265*rhog*ng)**(-bg/4.)
     86
     87  term1x2r=term1r*term2r
     88  term1x2s=term1s*term2s
     89  term1x2g=term1g*term2g
     90  do ilev=1,nlev
     91    do j=1,npoints
     92        rho=p(j,ilev)/(287.05*t(j,ilev))
     93        term3=(rho0/rho)**0.5
     94        ! ! Term 4 of Eq. (A19).
     95        t123r=term1x2r*term3
     96        t123s=term1x2s*term3
     97        t123g=term1x2g*term3
     98        term4r_ls=rain_ls(j,ilev)/(t123r)
     99        term4s_ls=snow_ls(j,ilev)/(t123s)
     100        term4g_ls=grpl_ls(j,ilev)/(t123g)
     101        term4r_cv=rain_cv(j,ilev)/(t123r)
     102        term4s_cv=snow_cv(j,ilev)/(t123s)
     103        do ibox=1,ncol
     104            mx_rain_ls(j,ibox,ilev)=0.
     105            mx_snow_ls(j,ibox,ilev)=0.
     106            mx_grpl_ls(j,ibox,ilev)=0.
     107            mx_rain_cv(j,ibox,ilev)=0.
     108            mx_snow_cv(j,ibox,ilev)=0.
     109            if ((prec_frac(j,ibox,ilev) .eq. 1.) .or. &
     110                  (prec_frac(j,ibox,ilev) .eq. 3.)) then
     111                mx_rain_ls(j,ibox,ilev)= &
     112                      (term4r_ls**(1./(1.+br/4.)))/rho
     113                mx_snow_ls(j,ibox,ilev)= &
     114                      (term4s_ls**(1./(1.+bs/4.)))/rho
     115                mx_grpl_ls(j,ibox,ilev)= &
     116                      (term4g_ls**(1./(1.+bg/4.)))/rho
     117            endif
     118            if ((prec_frac(j,ibox,ilev) .eq. 2.) .or. &
     119                  (prec_frac(j,ibox,ilev) .eq. 3.)) then
     120                mx_rain_cv(j,ibox,ilev)= &
     121                      (term4r_cv**(1./(1.+br/4.)))/rho
     122                mx_snow_cv(j,ibox,ilev)= &
     123                      (term4s_cv**(1./(1.+bs/4.)))/rho
     124            endif
     125        enddo ! loop over ncol
     126    enddo ! loop over npoints
     127  enddo ! loop over nlev
     128
     129end subroutine pf_to_mr
     130
  • LMDZ6/trunk/libf/phylmd/cosp/prec_scops.f90

    r5247 r5248  
    33! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
    44! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/prec_scops.f $
    5 ! 
    6 ! Redistribution and use in source and binary forms, with or without modification, are permitted 
     5!
     6! Redistribution and use in source and binary forms, with or without modification, are permitted
    77! provided that the following conditions are met:
    8 ! 
    9 !     * Redistributions of source code must retain the above copyright notice, this list
    10 !       of conditions and the following disclaimer.
    11 !     * Redistributions in binary form must reproduce the above copyright notice, this list
    12 !       of conditions and the following disclaimer in the documentation and/or other materials
    13 !       provided with the distribution.
    14 !     * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation
    15 !       nor the names of its contributors may be used to endorse or promote products derived from
    16 !       this software without specific prior written permission.
    17 ! 
    18 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
    19 ! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
    20 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
    21 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
    22 ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
    23 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
    24 ! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
     8!
     9! * Redistributions of source code must retain the above copyright notice, this list
     10!   of conditions and the following disclaimer.
     11! * Redistributions in binary form must reproduce the above copyright notice, this list
     12!   of conditions and the following disclaimer in the documentation and/or other materials
     13!   provided with the distribution.
     14! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation
     15!   nor the names of its contributors may be used to endorse or promote products derived from
     16!   this software without specific prior written permission.
     17!
     18! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
     19! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
     20! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
     21! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
     22! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
     23! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
     24! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
    2525! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    26      
    27       subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate,
    28      &                      frac_out,prec_frac)
    29 
    30 
    31       implicit none
    32 
    33       INTEGER npoints       !  number of model points in the horizontal
    34       INTEGER nlev          !  number of model levels in column
    35       INTEGER ncol          !  number of subcolumns
    36 
    37       INTEGER i,j,ilev,ibox,cv_col
    38      
    39       REAL ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev)
    40 
    41       REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
    42                               ! Equivalent of BOX in original version, but
    43                               ! indexed by column then row, rather than
    44                               ! by row then column
    45                               !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    46       REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
    47                                         ! 1 -> LS precipitation
    48                                         ! 2 -> CONV precipitation
    49                     ! 3 -> both
    50                                         !TOA to SURFACE!!!!!!!!!!!!!!!!!!
    51                    
    52       INTEGER flag_ls, flag_cv
    53       INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for
    54                        ! stratiform cloud and convective cloud in the vertical column
    55 
    56       cv_col = 0.05*ncol
    57       if (cv_col .eq. 0) cv_col=1
    58  
    59       do ilev=1,nlev
    60         do ibox=1,ncol
    61           do j=1,npoints
    62             prec_frac(j,ibox,ilev) = 0
    63           enddo
    64         enddo
     26
     27subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate, &
     28        frac_out,prec_frac)
     29
     30
     31  implicit none
     32
     33  INTEGER :: npoints       !  number of model points in the horizontal
     34  INTEGER :: nlev          !  number of model levels in column
     35  INTEGER :: ncol          !  number of subcolumns
     36
     37  INTEGER :: i,j,ilev,ibox,cv_col
     38
     39  REAL :: ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev)
     40
     41  REAL :: frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
     42                          ! ! Equivalent of BOX in original version, but
     43                          ! ! indexed by column then row, rather than
     44                          ! ! by row then column
     45                          ! !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     46  REAL :: prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
     47                                    ! ! 1 -> LS precipitation
     48                                    ! ! 2 -> CONV precipitation
     49                ! ! 3 -> both
     50                !                     !TOA to SURFACE!!!!!!!!!!!!!!!!!!
     51
     52  INTEGER :: flag_ls, flag_cv
     53  INTEGER :: frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for
     54                   ! ! stratiform cloud and convective cloud in the vertical column
     55
     56  cv_col = 0.05*ncol
     57  if (cv_col .eq. 0) cv_col=1
     58
     59  do ilev=1,nlev
     60    do ibox=1,ncol
     61      do j=1,npoints
     62        prec_frac(j,ibox,ilev) = 0
    6563      enddo
    66      
    67       do j=1,npoints
    68        do ibox=1,ncol
    69         frac_out_ls(j,ibox)=0
    70         frac_out_cv(j,ibox)=0
    71         flag_ls=0
    72         flag_cv=0
    73         do ilev=1,nlev
    74           if (frac_out(j,ibox,ilev) .eq. 1) then
    75             flag_ls=1
    76           endif
    77           if (frac_out(j,ibox,ilev) .eq. 2) then
    78             flag_cv=1
    79           endif
    80         enddo !loop over nlev
    81         if (flag_ls .eq. 1) then
    82            frac_out_ls(j,ibox)=1
    83         endif
    84         if (flag_cv .eq. 1) then
    85            frac_out_cv(j,ibox)=1
    86         endif
    87        enddo  ! loop over ncol
    88       enddo ! loop over npoints
    89 
    90 !      initialize the top layer     
    91        do j=1,npoints
    92         flag_ls=0
    93         flag_cv=0
    94    
    95         if (ls_p_rate(j,1) .gt. 0.) then
    96             do ibox=1,ncol ! possibility ONE
    97                 if (frac_out(j,ibox,1) .eq. 1) then
     64    enddo
     65  enddo
     66
     67  do j=1,npoints
     68   do ibox=1,ncol
     69    frac_out_ls(j,ibox)=0
     70    frac_out_cv(j,ibox)=0
     71    flag_ls=0
     72    flag_cv=0
     73    do ilev=1,nlev
     74      if (frac_out(j,ibox,ilev) .eq. 1) then
     75        flag_ls=1
     76      endif
     77      if (frac_out(j,ibox,ilev) .eq. 2) then
     78        flag_cv=1
     79      endif
     80    enddo !loop over nlev
     81    if (flag_ls .eq. 1) then
     82       frac_out_ls(j,ibox)=1
     83    endif
     84    if (flag_cv .eq. 1) then
     85       frac_out_cv(j,ibox)=1
     86    endif
     87   enddo  ! loop over ncol
     88  enddo ! loop over npoints
     89
     90   ! initialize the top layer
     91   do j=1,npoints
     92    flag_ls=0
     93    flag_cv=0
     94
     95    if (ls_p_rate(j,1) .gt. 0.) then
     96        do ibox=1,ncol ! possibility ONE
     97            if (frac_out(j,ibox,1) .eq. 1) then
     98                prec_frac(j,ibox,1) = 1
     99                flag_ls=1
     100            endif
     101        enddo ! loop over ncol
     102        if (flag_ls .eq. 0) then ! possibility THREE
     103            do ibox=1,ncol
     104                if (frac_out(j,ibox,2) .eq. 1) then
    98105                    prec_frac(j,ibox,1) = 1
    99106                    flag_ls=1
    100107                endif
    101108            enddo ! loop over ncol
    102             if (flag_ls .eq. 0) then ! possibility THREE
    103                 do ibox=1,ncol
    104                     if (frac_out(j,ibox,2) .eq. 1) then
    105                         prec_frac(j,ibox,1) = 1
    106                         flag_ls=1
    107                     endif
    108                 enddo ! loop over ncol
    109             endif
    110         if (flag_ls .eq. 0) then ! possibility Four
    111         do ibox=1,ncol
    112         if (frac_out_ls(j,ibox) .eq. 1) then
    113             prec_frac(j,ibox,1) = 1
    114             flag_ls=1
    115         endif
    116         enddo ! loop over ncol
    117         endif
    118         if (flag_ls .eq. 0) then ! possibility Five
    119         do ibox=1,ncol
    120     !     prec_frac(j,1:ncol,1) = 1
     109        endif
     110    if (flag_ls .eq. 0) then ! possibility Four
     111    do ibox=1,ncol
     112    if (frac_out_ls(j,ibox) .eq. 1) then
    121113        prec_frac(j,ibox,1) = 1
    122         enddo ! loop over ncol
    123             endif
    124         endif
    125        ! There is large scale precipitation
    126      
    127         if (cv_p_rate(j,1) .gt. 0.) then
    128          do ibox=1,ncol ! possibility ONE
    129           if (frac_out(j,ibox,1) .eq. 2) then
    130            if (prec_frac(j,ibox,1) .eq. 0) then
     114        flag_ls=1
     115    endif
     116    enddo ! loop over ncol
     117    endif
     118    if (flag_ls .eq. 0) then ! possibility Five
     119    do ibox=1,ncol
     120  !   !     prec_frac(j,1:ncol,1) = 1
     121    prec_frac(j,ibox,1) = 1
     122    enddo ! loop over ncol
     123        endif
     124    endif
     125   ! ! There is large scale precipitation
     126
     127    if (cv_p_rate(j,1) .gt. 0.) then
     128     do ibox=1,ncol ! possibility ONE
     129      if (frac_out(j,ibox,1) .eq. 2) then
     130       if (prec_frac(j,ibox,1) .eq. 0) then
     131    prec_frac(j,ibox,1) = 2
     132   else
     133    prec_frac(j,ibox,1) = 3
     134   endif
     135   flag_cv=1
     136  endif
     137    enddo ! loop over ncol
     138    if (flag_cv .eq. 0) then ! possibility THREE
     139    do ibox=1,ncol
     140    if (frac_out(j,ibox,2) .eq. 2) then
     141            if (prec_frac(j,ibox,1) .eq. 0) then
    131142        prec_frac(j,ibox,1) = 2
    132        else
     143        else
    133144        prec_frac(j,ibox,1) = 3
    134        endif
    135        flag_cv=1
     145        endif
     146        flag_cv=1
     147    endif
     148    enddo ! loop over ncol
     149    endif
     150    if (flag_cv .eq. 0) then ! possibility Four
     151    do ibox=1,ncol
     152    if (frac_out_cv(j,ibox) .eq. 1) then
     153            if (prec_frac(j,ibox,1) .eq. 0) then
     154        prec_frac(j,ibox,1) = 2
     155        else
     156        prec_frac(j,ibox,1) = 3
     157        endif
     158        flag_cv=1
     159    endif
     160    enddo ! loop over ncol
     161    endif
     162    if (flag_cv .eq. 0) then  ! possibility Five
     163    do ibox=1,cv_col
     164            if (prec_frac(j,ibox,1) .eq. 0) then
     165        prec_frac(j,ibox,1) = 2
     166        else
     167        prec_frac(j,ibox,1) = 3
     168        endif
     169    enddo !loop over cv_col
     170        endif
     171    endif
     172    ! ! There is convective precipitation
     173
     174    enddo ! loop over npoints
     175   ! end of initializing the top layer
     176
     177  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     178
     179  ! working on the levels from top to surface
     180  do ilev=2,nlev
     181   do j=1,npoints
     182    flag_ls=0
     183    flag_cv=0
     184
     185    if (ls_p_rate(j,ilev) .gt. 0.) then
     186     do ibox=1,ncol ! possibility ONE&TWO
     187      if ((frac_out(j,ibox,ilev) .eq. 1) .or. &
     188            ((prec_frac(j,ibox,ilev-1) .eq. 1) &
     189            .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then
     190       prec_frac(j,ibox,ilev) = 1
     191       flag_ls=1
    136192      endif
    137         enddo ! loop over ncol
    138         if (flag_cv .eq. 0) then ! possibility THREE
    139         do ibox=1,ncol
    140         if (frac_out(j,ibox,2) .eq. 2) then
    141                 if (prec_frac(j,ibox,1) .eq. 0) then
    142             prec_frac(j,ibox,1) = 2
    143             else
    144             prec_frac(j,ibox,1) = 3
    145             endif
    146             flag_cv=1
    147         endif
    148         enddo ! loop over ncol
    149         endif
    150         if (flag_cv .eq. 0) then ! possibility Four
    151         do ibox=1,ncol
    152         if (frac_out_cv(j,ibox) .eq. 1) then
    153                 if (prec_frac(j,ibox,1) .eq. 0) then
    154             prec_frac(j,ibox,1) = 2
    155             else
    156             prec_frac(j,ibox,1) = 3
    157             endif
    158             flag_cv=1
    159         endif
    160         enddo ! loop over ncol
    161         endif
    162         if (flag_cv .eq. 0) then  ! possibility Five
    163         do ibox=1,cv_col
    164                 if (prec_frac(j,ibox,1) .eq. 0) then
    165             prec_frac(j,ibox,1) = 2
    166             else
    167             prec_frac(j,ibox,1) = 3
    168             endif
    169         enddo !loop over cv_col
    170             endif
    171         endif
    172         ! There is convective precipitation
    173        
    174         enddo ! loop over npoints
    175 !      end of initializing the top layer
    176 
    177 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    178 
    179 !     working on the levels from top to surface
    180       do ilev=2,nlev
    181        do j=1,npoints
    182         flag_ls=0
    183         flag_cv=0
    184    
    185         if (ls_p_rate(j,ilev) .gt. 0.) then
    186          do ibox=1,ncol ! possibility ONE&TWO
    187           if ((frac_out(j,ibox,ilev) .eq. 1) .or.
    188      &       ((prec_frac(j,ibox,ilev-1) .eq. 1)
    189      &       .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then
    190            prec_frac(j,ibox,ilev) = 1
    191            flag_ls=1
    192           endif
    193         enddo ! loop over ncol
    194         if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
    195         do ibox=1,ncol
    196         if (frac_out(j,ibox,ilev+1) .eq. 1) then
    197             prec_frac(j,ibox,ilev) = 1
    198             flag_ls=1
    199         endif
    200         enddo ! loop over ncol
    201         endif
    202         if (flag_ls .eq. 0) then ! possibility Four
    203         do ibox=1,ncol
    204         if (frac_out_ls(j,ibox) .eq. 1) then
    205             prec_frac(j,ibox,ilev) = 1
    206             flag_ls=1
    207         endif
    208         enddo ! loop over ncol
    209         endif
    210         if (flag_ls .eq. 0) then ! possibility Five
    211         do ibox=1,ncol
    212 !     prec_frac(j,1:ncol,ilev) = 1
     193    enddo ! loop over ncol
     194    if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
     195    do ibox=1,ncol
     196    if (frac_out(j,ibox,ilev+1) .eq. 1) then
    213197        prec_frac(j,ibox,ilev) = 1
    214         enddo ! loop over ncol
    215          endif
    216       endif ! There is large scale precipitation
    217    
    218         if (cv_p_rate(j,ilev) .gt. 0.) then
    219          do ibox=1,ncol ! possibility ONE&TWO
    220           if ((frac_out(j,ibox,ilev) .eq. 2) .or.
    221      &       ((prec_frac(j,ibox,ilev-1) .eq. 2)
    222      &       .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then
     198        flag_ls=1
     199    endif
     200    enddo ! loop over ncol
     201    endif
     202    if (flag_ls .eq. 0) then ! possibility Four
     203    do ibox=1,ncol
     204    if (frac_out_ls(j,ibox) .eq. 1) then
     205        prec_frac(j,ibox,ilev) = 1
     206        flag_ls=1
     207    endif
     208    enddo ! loop over ncol
     209    endif
     210    if (flag_ls .eq. 0) then ! possibility Five
     211    do ibox=1,ncol
     212  ! prec_frac(j,1:ncol,ilev) = 1
     213    prec_frac(j,ibox,ilev) = 1
     214    enddo ! loop over ncol
     215     endif
     216  endif ! There is large scale precipitation
     217
     218    if (cv_p_rate(j,ilev) .gt. 0.) then
     219     do ibox=1,ncol ! possibility ONE&TWO
     220      if ((frac_out(j,ibox,ilev) .eq. 2) .or. &
     221            ((prec_frac(j,ibox,ilev-1) .eq. 2) &
     222            .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then
     223        if (prec_frac(j,ibox,ilev) .eq. 0) then
     224     prec_frac(j,ibox,ilev) = 2
     225    else
     226     prec_frac(j,ibox,ilev) = 3
     227    endif
     228    flag_cv=1
     229    endif
     230   enddo ! loop over ncol
     231    if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
     232    do ibox=1,ncol
     233    if (frac_out(j,ibox,ilev+1) .eq. 2) then
    223234            if (prec_frac(j,ibox,ilev) .eq. 0) then
    224          prec_frac(j,ibox,ilev) = 2
    225         else
    226          prec_frac(j,ibox,ilev) = 3
    227         endif
    228         flag_cv=1
    229         endif
    230        enddo ! loop over ncol
    231         if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
    232         do ibox=1,ncol
    233         if (frac_out(j,ibox,ilev+1) .eq. 2) then
    234                 if (prec_frac(j,ibox,ilev) .eq. 0) then
    235             prec_frac(j,ibox,ilev) = 2
    236             else
    237             prec_frac(j,ibox,ilev) = 3
    238             endif
    239             flag_cv=1
    240         endif
    241         enddo ! loop over ncol
    242         endif
    243         if (flag_cv .eq. 0) then ! possibility Four
    244         do ibox=1,ncol
    245         if (frac_out_cv(j,ibox) .eq. 1) then
    246                 if (prec_frac(j,ibox,ilev) .eq. 0) then
    247             prec_frac(j,ibox,ilev) = 2
    248             else
    249             prec_frac(j,ibox,ilev) = 3
    250             endif
    251             flag_cv=1
    252         endif
    253         enddo ! loop over ncol
    254         endif
    255         if (flag_cv .eq. 0) then  ! possibility Five
    256         do ibox=1,cv_col
    257                 if (prec_frac(j,ibox,ilev) .eq. 0) then
    258             prec_frac(j,ibox,ilev) = 2
    259             else
    260             prec_frac(j,ibox,ilev) = 3
    261             endif
    262         enddo !loop over cv_col
    263             endif
    264         endif ! There is convective precipitation
    265    
    266         enddo ! loop over npoints
    267         enddo ! loop over nlev
    268 
    269       end
    270 
     235        prec_frac(j,ibox,ilev) = 2
     236        else
     237        prec_frac(j,ibox,ilev) = 3
     238        endif
     239        flag_cv=1
     240    endif
     241    enddo ! loop over ncol
     242    endif
     243    if (flag_cv .eq. 0) then ! possibility Four
     244    do ibox=1,ncol
     245    if (frac_out_cv(j,ibox) .eq. 1) then
     246            if (prec_frac(j,ibox,ilev) .eq. 0) then
     247        prec_frac(j,ibox,ilev) = 2
     248        else
     249        prec_frac(j,ibox,ilev) = 3
     250        endif
     251        flag_cv=1
     252    endif
     253    enddo ! loop over ncol
     254    endif
     255    if (flag_cv .eq. 0) then  ! possibility Five
     256    do ibox=1,cv_col
     257            if (prec_frac(j,ibox,ilev) .eq. 0) then
     258        prec_frac(j,ibox,ilev) = 2
     259        else
     260        prec_frac(j,ibox,ilev) = 3
     261        endif
     262    enddo !loop over cv_col
     263        endif
     264    endif ! There is convective precipitation
     265
     266    enddo ! loop over npoints
     267    enddo ! loop over nlev
     268
     269end subroutine prec_scops
     270
  • LMDZ6/trunk/libf/phylmd/cosp/scops.f90

    r5247 r5248  
    1       subroutine scops(npoints,nlev,ncol,seed,cc,conv,
    2      &                 overlap,frac_out,ncolprint)
    3 
    4 
    5 ! *****************************COPYRIGHT****************************
    6 ! (c) British Crown Copyright 2009, the Met Office.
    7 ! All rights reserved.
    8 ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
    9 ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/scops.f $
    10 !
    11 ! Redistribution and use in source and binary forms, with or without
    12 ! modification, are permitted provided that the
    13 ! following conditions are met:
    14 !
    15 !     * Redistributions of source code must retain the above
    16 !       copyright  notice, this list of conditions and the following
    17 !       disclaimer.
    18 !     * Redistributions in binary form must reproduce the above
    19 !       copyright notice, this list of conditions and the following
    20 !       disclaimer in the documentation and/or other materials
    21 !       provided with the distribution.
    22 !     * Neither the name of the Met Office nor the names of its
    23 !       contributors may be used to endorse or promote products
    24 !       derived from this software without specific prior written
    25 !       permission.
    26 !
    27 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    28 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    29 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
    30 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
    31 ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    32 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
    33 ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
    34 ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
    35 ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
    36 ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
    37 ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 
    38 !
    39 ! *****************************COPYRIGHT*******************************
    40 ! *****************************COPYRIGHT*******************************
    41 ! *****************************COPYRIGHT*******************************
    42 
    43       implicit none
    44 
    45       INTEGER npoints       !  number of model points in the horizontal
    46       INTEGER nlev          !  number of model levels in column
    47       INTEGER ncol          !  number of subcolumns
    48 
    49 
    50       INTEGER overlap         !  overlap type
    51                               !  1=max
    52                               !  2=rand
    53                               !  3=max/rand
    54       REAL cc(npoints,nlev)
    55                   !  input cloud cover in each model level (fraction)
    56                   !  NOTE:  This is the HORIZONTAL area of each
    57                   !         grid box covered by clouds
    58 
    59       REAL conv(npoints,nlev)
    60                   !  input convective cloud cover in each model
    61                   !   level (fraction)
    62                   !  NOTE:  This is the HORIZONTAL area of each
    63                   !         grid box covered by convective clouds
    64 
    65       INTEGER i,j,ilev,ibox,ncolprint,ilev2
    66 
    67       REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
    68                               ! Equivalent of BOX in original version, but
    69                               ! indexed by column then row, rather than
    70                               ! by row then column
    71 
    72 
    73       INTEGER seed(npoints)
    74       !  seed values for marsaglia  random number generator
    75       !  It is recommended that the seed is set
    76       !  to a different value for each model
    77       !  gridbox it is called on, as it is
    78       !  possible that the choice of the same
    79       !  seed value every time may introduce some
    80       !  statistical bias in the results, particularly
    81       !  for low values of NCOL.
    82 
    83       REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction)
    84                                         ! with extra layer of zeroes on top
    85                                         ! in this version this just contains the values input
    86                                         ! from cc but with an extra level
    87 
    88       REAL threshold(npoints,ncol)   ! pointer to position in gridbox
    89       REAL maxocc(npoints,ncol)      ! Flag for max overlapped conv cld
    90       REAL maxosc(npoints,ncol)      ! Flag for max overlapped strat cld
    91 
    92       REAL boxpos(npoints,ncol)      ! ordered pointer to position in gridbox
    93 
    94       REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold
    95                                         ! is chosen
    96 
    97       REAL ran(npoints)                 ! vector of random numbers
    98 
    99       INTEGER irand,i2_16,huge32,overflow_32  ! variables for RNG
    100       PARAMETER(huge32=2147483647)
    101       i2_16=65536
    102 
    103       do ibox=1,ncol
    104         do j=1,npoints
    105         boxpos(j,ibox)=(ibox-.5)/ncol
    106         enddo
    107       enddo
    108 
    109 !     ---------------------------------------------------!
    110 !     Initialise working variables
    111 !     ---------------------------------------------------!
    112 
    113 !     Initialised frac_out to zero
    114 
    115       do ilev=1,nlev
    116         do ibox=1,ncol
    117           do j=1,npoints
    118           frac_out(j,ibox,ilev)=0.0
     1subroutine scops(npoints,nlev,ncol,seed,cc,conv, &
     2        overlap,frac_out,ncolprint)
     3
     4
     5  ! *****************************COPYRIGHT****************************
     6  ! (c) British Crown Copyright 2009, the Met Office.
     7  ! All rights reserved.
     8  ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     9  ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/scops.f $
     10  !
     11  ! Redistribution and use in source and binary forms, with or without
     12  ! modification, are permitted provided that the
     13  ! following conditions are met:
     14  !
     15  ! * Redistributions of source code must retain the above
     16  !   copyright  notice, this list of conditions and the following
     17  !   disclaimer.
     18  ! * Redistributions in binary form must reproduce the above
     19  !   copyright notice, this list of conditions and the following
     20  !   disclaimer in the documentation and/or other materials
     21  !   provided with the distribution.
     22  ! * Neither the name of the Met Office nor the names of its
     23  !   contributors may be used to endorse or promote products
     24  !   derived from this software without specific prior written
     25  !   permission.
     26  !
     27  ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
     28  ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
     29  ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
     30  ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
     31  ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
     32  ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
     33  ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
     34  ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
     35  ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
     36  ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
     37  ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     38  !
     39  ! *****************************COPYRIGHT*******************************
     40  ! *****************************COPYRIGHT*******************************
     41  ! *****************************COPYRIGHT*******************************
     42
     43  implicit none
     44
     45  INTEGER :: npoints       !  number of model points in the horizontal
     46  INTEGER :: nlev          !  number of model levels in column
     47  INTEGER :: ncol          !  number of subcolumns
     48
     49
     50  INTEGER :: overlap         !  overlap type
     51                          ! !  1=max
     52                          ! !  2=rand
     53                          ! !  3=max/rand
     54  REAL :: cc(npoints,nlev)
     55              ! !  input cloud cover in each model level (fraction)
     56              ! !  NOTE:  This is the HORIZONTAL area of each
     57              ! !         grid box covered by clouds
     58
     59  REAL :: conv(npoints,nlev)
     60              ! !  input convective cloud cover in each model
     61              ! !   level (fraction)
     62              ! !  NOTE:  This is the HORIZONTAL area of each
     63              ! !         grid box covered by convective clouds
     64
     65  INTEGER :: i,j,ilev,ibox,ncolprint,ilev2
     66
     67  REAL :: frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
     68                          ! ! Equivalent of BOX in original version, but
     69                          ! ! indexed by column then row, rather than
     70                          ! ! by row then column
     71
     72
     73  INTEGER :: seed(npoints)
     74  ! !  seed values for marsaglia  random number generator
     75  ! !  It is recommended that the seed is set
     76  ! !  to a different value for each model
     77  ! !  gridbox it is called on, as it is
     78  ! !  possible that the choice of the same
     79  ! !  seed value every time may introduce some
     80  ! !  statistical bias in the results, particularly
     81  ! !  for low values of NCOL.
     82
     83  REAL :: tca(npoints,0:nlev) ! total cloud cover in each model level (fraction)
     84                                    ! ! with extra layer of zeroes on top
     85                                    ! ! in this version this just contains the values input
     86                                    ! ! from cc but with an extra level
     87
     88  REAL :: threshold(npoints,ncol)   ! pointer to position in gridbox
     89  REAL :: maxocc(npoints,ncol)      ! Flag for max overlapped conv cld
     90  REAL :: maxosc(npoints,ncol)      ! Flag for max overlapped strat cld
     91
     92  REAL :: boxpos(npoints,ncol)      ! ordered pointer to position in gridbox
     93
     94  REAL :: threshold_min(npoints,ncol) ! minimum value to define range in with new threshold
     95                                    ! ! is chosen
     96
     97  REAL :: ran(npoints)                 ! vector of random numbers
     98
     99  INTEGER :: irand,i2_16,huge32,overflow_32  ! variables for RNG
     100  PARAMETER(huge32=2147483647)
     101  i2_16=65536
     102
     103  do ibox=1,ncol
     104    do j=1,npoints
     105    boxpos(j,ibox)=(ibox-.5)/ncol
     106    enddo
     107  enddo
     108
     109  ! ---------------------------------------------------!
     110  ! Initialise working variables
     111  ! ---------------------------------------------------!
     112
     113  ! Initialised frac_out to zero
     114
     115  do ilev=1,nlev
     116    do ibox=1,ncol
     117      do j=1,npoints
     118      frac_out(j,ibox,ilev)=0.0
     119      enddo
     120    enddo
     121  enddo
     122
     123  ! assign 2d tca array using 1d input array cc
     124
     125  do j=1,npoints
     126    tca(j,0)=0
     127  enddo
     128
     129  do ilev=1,nlev
     130    do j=1,npoints
     131      tca(j,ilev)=cc(j,ilev)
     132    enddo
     133  enddo
     134
     135  if (ncolprint.ne.0) then
     136    write (6,'(a)') 'frac_out_pp_rev:'
     137      do j=1,npoints,1000
     138      write(6,'(a10)') 'j='
     139      write(6,'(8I10)') j
     140      write (6,'(8f5.2)') &
     141            ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
     142
     143      enddo
     144    write (6,'(a)') 'ncol:'
     145    write (6,'(I3)') ncol
     146  endif
     147  if (ncolprint.ne.0) then
     148    write (6,'(a)') 'last_frac_pp:'
     149      do j=1,npoints,1000
     150      write(6,'(a10)') 'j='
     151      write(6,'(8I10)') j
     152      write (6,'(8f5.2)') (tca(j,0))
     153      enddo
     154  endif
     155
     156  ! ---------------------------------------------------!
     157  ! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS
     158  ! frac_out is the array that contains the information
     159  ! where 0 is no cloud, 1 is a stratiform cloud and 2 is a
     160  ! convective cloud
     161
     162  ! !loop over vertical levels
     163  DO ilev = 1,nlev
     164
     165  ! Initialise threshold
     166
     167    IF (ilev.eq.1) then
     168      ! ! If max overlap
     169      IF (overlap.eq.1) then
     170        ! ! select pixels spread evenly
     171        ! ! across the gridbox
     172          DO ibox=1,ncol
     173            do j=1,npoints
     174              threshold(j,ibox)=boxpos(j,ibox)
     175            enddo
    119176          enddo
    120         enddo
    121       enddo
    122 
    123 !     assign 2d tca array using 1d input array cc
    124 
    125       do j=1,npoints
    126         tca(j,0)=0
    127       enddo
    128 
    129       do ilev=1,nlev
    130         do j=1,npoints
    131           tca(j,ilev)=cc(j,ilev)
    132         enddo
    133       enddo
    134 
    135       if (ncolprint.ne.0) then
    136         write (6,'(a)') 'frac_out_pp_rev:'
    137           do j=1,npoints,1000
    138           write(6,'(a10)') 'j='
    139           write(6,'(8I10)') j
    140           write (6,'(8f5.2)')
    141      &     ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
    142 
     177      ELSE
     178          DO ibox=1,ncol
     179            include 'congvec.h'
     180            ! ! select random pixels from the non-convective
     181            ! ! part the gridbox ( some will be converted into
     182            ! ! convective pixels below )
     183            do j=1,npoints
     184              threshold(j,ibox)= &
     185                    conv(j,ilev)+(1-conv(j,ilev))*ran(j)
     186            enddo
    143187          enddo
    144         write (6,'(a)') 'ncol:'
    145         write (6,'(I3)') ncol
    146       endif
    147       if (ncolprint.ne.0) then
    148         write (6,'(a)') 'last_frac_pp:'
    149           do j=1,npoints,1000
    150           write(6,'(a10)') 'j='
    151           write(6,'(8I10)') j
    152           write (6,'(8f5.2)') (tca(j,0))
    153           enddo
    154       endif
    155 
    156 !     ---------------------------------------------------!
    157 !     ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS
    158 !     frac_out is the array that contains the information
    159 !     where 0 is no cloud, 1 is a stratiform cloud and 2 is a
    160 !     convective cloud
    161      
    162       !loop over vertical levels
    163       DO 200 ilev = 1,nlev
    164                                  
    165 !     Initialise threshold
    166 
    167         IF (ilev.eq.1) then
    168           ! If max overlap
    169           IF (overlap.eq.1) then
    170             ! select pixels spread evenly
    171             ! across the gridbox
    172               DO ibox=1,ncol
    173                 do j=1,npoints
    174                   threshold(j,ibox)=boxpos(j,ibox)
    175                 enddo
    176               enddo
    177           ELSE
    178               DO ibox=1,ncol
    179                 include 'congvec.h'
    180                 ! select random pixels from the non-convective
    181                 ! part the gridbox ( some will be converted into
    182                 ! convective pixels below )
    183                 do j=1,npoints
    184                   threshold(j,ibox)=
    185      &            conv(j,ilev)+(1-conv(j,ilev))*ran(j)
    186                 enddo
    187               enddo
    188             ENDIF
    189             IF (ncolprint.ne.0) then
    190               write (6,'(a)') 'threshold_nsf2:'
    191                 do j=1,npoints,1000
    192                 write(6,'(a10)') 'j='
    193                 write(6,'(8I10)') j
    194                 write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
    195                 enddo
    196             ENDIF
    197188        ENDIF
    198 
    199189        IF (ncolprint.ne.0) then
    200             write (6,'(a)') 'ilev:'
    201             write (6,'(I2)') ilev
    202         ENDIF
    203 
    204         DO ibox=1,ncol
    205 
    206           ! All versions
    207           do j=1,npoints
    208             if (boxpos(j,ibox).le.conv(j,ilev)) then
    209               maxocc(j,ibox) = 1
    210             else
    211               maxocc(j,ibox) = 0
    212             end if
    213           enddo
    214 
    215           ! Max overlap
    216           if (overlap.eq.1) then
    217             do j=1,npoints
    218               threshold_min(j,ibox)=conv(j,ilev)
    219               maxosc(j,ibox)=1
    220             enddo
    221           endif
    222 
    223           ! Random overlap
    224           if (overlap.eq.2) then
    225             do j=1,npoints
    226               threshold_min(j,ibox)=conv(j,ilev)
    227               maxosc(j,ibox)=0
    228             enddo
    229           endif
    230 
    231           ! Max/Random overlap
    232           if (overlap.eq.3) then
    233             do j=1,npoints
    234               threshold_min(j,ibox)=max(conv(j,ilev),
    235      &          min(tca(j,ilev-1),tca(j,ilev)))
    236               if (threshold(j,ibox)
    237      &          .lt.min(tca(j,ilev-1),tca(j,ilev))
    238      &          .and.(threshold(j,ibox).gt.conv(j,ilev))) then
    239                    maxosc(j,ibox)= 1
    240               else
    241                    maxosc(j,ibox)= 0
    242               end if
    243             enddo
    244           endif
    245    
    246           ! Reset threshold
    247 
    248           include 'congvec.h'
    249 
    250           do j=1,npoints
    251             threshold(j,ibox)=
    252               !if max overlapped conv cloud
    253      &        maxocc(j,ibox) * (                                       
    254      &            boxpos(j,ibox)                                               
    255      &        ) +                                                     
    256               !else
    257      &        (1-maxocc(j,ibox)) * (                                   
    258                   !if max overlapped strat cloud
    259      &            (maxosc(j,ibox)) * (                                 
    260                       !threshold=boxpos
    261      &                threshold(j,ibox)                                       
    262      &            ) +                                                 
    263                   !else
    264      &            (1-maxosc(j,ibox)) * (                               
    265                       !threshold_min=random[thrmin,1]
    266      &                threshold_min(j,ibox)+
    267      &                  (1-threshold_min(j,ibox))*ran(j) 
    268      &           )
    269      &        )
    270           enddo
    271 
    272         ENDDO ! ibox
    273 
    274 !          Fill frac_out with 1's where tca is greater than the threshold
    275 
    276            DO ibox=1,ncol
    277              do j=1,npoints
    278                if (tca(j,ilev).gt.threshold(j,ibox)) then
    279                frac_out(j,ibox,ilev)=1
    280                else
    281                frac_out(j,ibox,ilev)=0
    282                end if               
    283              enddo
    284            ENDDO
    285 
    286 !         Code to partition boxes into startiform and convective parts
    287 !         goes here
    288 
    289            DO ibox=1,ncol
    290              do j=1,npoints
    291                 if (threshold(j,ibox).le.conv(j,ilev)) then
    292                     ! = 2 IF threshold le conv(j)
    293                     frac_out(j,ibox,ilev) = 2
    294                 else
    295                     ! = the same IF NOT threshold le conv(j)
    296                     frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev)
    297                 end if
    298              enddo
    299            ENDDO
    300 
    301 !         Set last_frac to tca at this level, so as to be tca
    302 !         from last level next time round
    303 
    304           if (ncolprint.ne.0) then
    305 
    306             do j=1,npoints ,1000
     190          write (6,'(a)') 'threshold_nsf2:'
     191            do j=1,npoints,1000
    307192            write(6,'(a10)') 'j='
    308193            write(6,'(8I10)') j
    309             write (6,'(a)') 'last_frac:'
    310             write (6,'(8f5.2)') (tca(j,ilev-1))
    311    
    312             write (6,'(a)') 'conv:'
    313             write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint)
    314    
    315             write (6,'(a)') 'max_overlap_cc:'
    316             write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
    317    
    318             write (6,'(a)') 'max_overlap_sc:'
    319             write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
    320    
    321             write (6,'(a)') 'threshold_min_nsf2:'
    322             write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
    323    
    324             write (6,'(a)') 'threshold_nsf2:'
    325194            write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
    326    
    327             write (6,'(a)') 'frac_out_pp_rev:'
    328             write (6,'(8f5.2)')
    329      &       ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
    330           enddo
    331           endif
    332 
    333 200   CONTINUE    !loop over nlev
    334 
    335 
    336       end
    337 
     195            enddo
     196        ENDIF
     197    ENDIF
     198
     199    IF (ncolprint.ne.0) then
     200        write (6,'(a)') 'ilev:'
     201        write (6,'(I2)') ilev
     202    ENDIF
     203
     204    DO ibox=1,ncol
     205
     206      ! ! All versions
     207      do j=1,npoints
     208        if (boxpos(j,ibox).le.conv(j,ilev)) then
     209          maxocc(j,ibox) = 1
     210        else
     211          maxocc(j,ibox) = 0
     212        end if
     213      enddo
     214
     215      ! ! Max overlap
     216      if (overlap.eq.1) then
     217        do j=1,npoints
     218          threshold_min(j,ibox)=conv(j,ilev)
     219          maxosc(j,ibox)=1
     220        enddo
     221      endif
     222
     223      ! ! Random overlap
     224      if (overlap.eq.2) then
     225        do j=1,npoints
     226          threshold_min(j,ibox)=conv(j,ilev)
     227          maxosc(j,ibox)=0
     228        enddo
     229      endif
     230
     231      ! ! Max/Random overlap
     232      if (overlap.eq.3) then
     233        do j=1,npoints
     234          threshold_min(j,ibox)=max(conv(j,ilev), &
     235                min(tca(j,ilev-1),tca(j,ilev)))
     236          if (threshold(j,ibox) &
     237                .lt.min(tca(j,ilev-1),tca(j,ilev)) &
     238                .and.(threshold(j,ibox).gt.conv(j,ilev))) then
     239               maxosc(j,ibox)= 1
     240          else
     241               maxosc(j,ibox)= 0
     242          end if
     243        enddo
     244      endif
     245
     246      ! ! Reset threshold
     247
     248      include 'congvec.h'
     249
     250      do j=1,npoints
     251        threshold(j,ibox)= &
     252          ! !if max overlapped conv cloud
     253              maxocc(j,ibox) * ( &
     254              boxpos(j,ibox) &
     255              ) + &
     256          ! !else
     257              (1-maxocc(j,ibox)) * ( &
     258              ! !if max overlapped strat cloud
     259              (maxosc(j,ibox)) * ( &
     260                  ! !threshold=boxpos
     261              threshold(j,ibox) &
     262              ) + &
     263              ! !else
     264              (1-maxosc(j,ibox)) * ( &
     265                  ! !threshold_min=random[thrmin,1]
     266              threshold_min(j,ibox)+ &
     267              (1-threshold_min(j,ibox))*ran(j) &
     268              ) &
     269              )
     270      enddo
     271
     272    ENDDO ! ibox
     273
     274       ! Fill frac_out with 1's where tca is greater than the threshold
     275
     276       DO ibox=1,ncol
     277         do j=1,npoints
     278           if (tca(j,ilev).gt.threshold(j,ibox)) then
     279           frac_out(j,ibox,ilev)=1
     280           else
     281           frac_out(j,ibox,ilev)=0
     282           end if
     283         enddo
     284       ENDDO
     285
     286      ! Code to partition boxes into startiform and convective parts
     287      ! goes here
     288
     289       DO ibox=1,ncol
     290         do j=1,npoints
     291            if (threshold(j,ibox).le.conv(j,ilev)) then
     292                ! ! = 2 IF threshold le conv(j)
     293                frac_out(j,ibox,ilev) = 2
     294            else
     295                ! ! = the same IF NOT threshold le conv(j)
     296                frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev)
     297            end if
     298         enddo
     299       ENDDO
     300
     301      ! Set last_frac to tca at this level, so as to be tca
     302      ! from last level next time round
     303
     304      if (ncolprint.ne.0) then
     305
     306        do j=1,npoints ,1000
     307        write(6,'(a10)') 'j='
     308        write(6,'(8I10)') j
     309        write (6,'(a)') 'last_frac:'
     310        write (6,'(8f5.2)') (tca(j,ilev-1))
     311
     312        write (6,'(a)') 'conv:'
     313        write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint)
     314
     315        write (6,'(a)') 'max_overlap_cc:'
     316        write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
     317
     318        write (6,'(a)') 'max_overlap_sc:'
     319        write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
     320
     321        write (6,'(a)') 'threshold_min_nsf2:'
     322        write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
     323
     324        write (6,'(a)') 'threshold_nsf2:'
     325        write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
     326
     327        write (6,'(a)') 'frac_out_pp_rev:'
     328        write (6,'(8f5.2)') &
     329              ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
     330      enddo
     331      endif
     332
     333  END DO
     334
     335
     336end subroutine scops
     337
Note: See TracChangeset for help on using the changeset viewer.