!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***S/P MPRECIP4
*
#include "phy_macros_f.h"
SUBROUTINE MPRECIP4 (T, Q, R, W, PS, KCL, SATUCO, 1,13
+ S , TAU ,ITADJ, MAXADJ, NSUPS,
+ N, NK, KA, NDIM)
*
#include "impnone.cdk"
*
INTEGER N,NK,NDIM,KA
INTEGER MAXADJ,NSUPS,ITADJ(MAXADJ)
REAL T(NDIM,NK),Q(NDIM,NK),R(N),W(NDIM,NK),PS(N),KCL(N)
REAL S(n,NK)
REAL TAU
LOGICAL SATUCO
*
*Author
* R. Benoit RPN(Nov 1979)( RFE )
*
*Revision
* 001 C. Beaudoin RPN(Nov 83)( SEF )
* 002 J. Cote RPN(June 85)( Optimization , Documentation )
* 003 M. Lepine - RFE model code revision project (Jan87)
* - Add parameter NDIM
* - Add a list of adjustment counters
* R. Benoit - conversions TV <-> T for before/after
* convective adjustment
* 004 M. Lepine - Initialize NADJ (Feb 88)
* 005 N. Brunet (May90)
* Standardization of thermodynamic functions
* 006 H. Ritchie, A.M. Leduc, C. Girard (May91)
* Change the call ABORT to call STOP(for ITER too big)
* N. Brunet (May91)
* New version of thermodynamic functions
* and file of constants
* 007 R. Benoit (Aug 93) Local Sigma
* 008 G. Pellerin (Nov93) adaptation to MACROTASKING in EFR
* Change call to MCONADJ
* Change name from MPRECIP to MPRECIP2
* 009 B. Bilodeau (June 1994) New physics interface
* 010 B. Bilodeau (Jan 1997) Dynamic memory allocation for F
*
*Object
* to control moist convective adjustment and calculate
* instantaneous rate
*
*Arguments
*
* - Input/Output -
* T temperature
* Q specific humidity
*
* - Output -
* R instantaneous rate of precipitation
*
* - Input -
* W vertical motion
* PS surface pressure
* KCL index of 1st level in the boundary layer - 3 (N)
* SATUCO .TRUE. if water/ice phase for saturation
* .FALSE. if water phase only for saturation
* S sigma levels
* TAU FACTDT * timestep (see common block OPTIONS)
*
* - Output -
* ITADJ number of points requiring more adjustment after iteration
* (maximum of MAXADJ iterations)
*
* - Input -
* MAXADJ dimension of ITADJ
*
* - Input/Output -
* NSUPS counter of number of points for more iterations (if
* necessary) and with GAC>0
*
* - Input -
* N horizontal dimension
* NK vertical dimension
* KA level to extract
* NDIM 1st dimension of T, Q, and W
*
*
*Notes
* We must use the compatible versions of MCONADJ2 and WETCON2
*
*IMPLICITES
*
#include "acmcon.cdk"
*
*MODULES
*
EXTERNAL MCONADJ2, WETCON2
*
* SCATTER/GATHER SIMPLE ET MULTIPLE
*
EXTERNAL SCATTER, GATHER, VSCATR, VGATHR
*
*
**
*
************************************************************************
* AUTOMATIC ARRAYS
************************************************************************
*
* careful with dimension of stawsj
AUTOMATIC ( STAWSJ , REAL , (N,KA-1,6 ) )
AUTOMATIC ( DELWETJ , REAL , (N,NK ) )
*
AUTOMATIC ( F , INTEGER , (N*6 ) )
AUTOMATIC ( G , INTEGER , (10*N*(NK+1)) )
*
************************************************************************
*
*
INTEGER RDOT,NADJ
INTEGER DQ,DT,H,HS,P,QS
INTEGER IT,IQ,IR,IW,IPS,IKCL,IMAX,ITER,I,J,K,KREP,NN
INTEGER IKZ
integer ista, idel, is
*
#include "consphy.cdk"
#include "dintern.cdk"
#include "fintern.cdk"
DO 6 I=1,MAXADJ
6 ITADJ(I) = 0
*
DO 10 J=1,N
R(J) = 0.0
10 CONTINUE
DO 15 K=1,NK
DO 15 J=1,N
Q(J,K) = MAX( Q(J,K) , 0.0 )
15 CONTINUE
*
KREP = NK/2+1
ITER = 0
16 CONTINUE
NADJ = 0
RDOT = 0
*
DQ = 1
DT = DQ + N
H = DT + N
HS = H + N
P = HS + N
QS = P + N
IMAX = QS + N - 1
*
* prepare stawsj, delwetj (from 2D sigma)
*
call wetcon2(stawsj, s, delwetj, n, ka, ka.lt.nk)
*
CALL MCONADJ2( T , Q , R , W(1,KREP) , PS , KCL ,
$ STAWSj , DELWETj ,
% S , F(DQ) , F(DT) , F(H) , F(HS) , F(P) ,
% F(QS) , NADJ , ITER , N , NK ,
% KA, NDIM, SATUCO)
*
NADJ = 0
DO 20 I = 1,N
IF ( F(DQ+I-1) .GT. 0 ) THEN
NADJ = NADJ + 1
F(NADJ) = I
END IF
20 CONTINUE
*
*
ITADJ(ITER)=NADJ
25 IF ( NADJ.GT.0 ) THEN
*
IF ( ITER.EQ.ABS( ITRMAX ) ) THEN
IF ( ITRMAX.LT.0 ) THEN
PRINT *,'ARRET DANS MPRECIP ITER = ',ITER
CALL ABORT
ELSE
PRINT *,'RETOUR DE MPRECIP ITER = ',ITER
GO TO 35
ENDIF
ENDIF
*
DQ = 1
DT = DQ + NADJ
H = DT + NADJ
HS = H + NADJ
P = HS + NADJ
QS = P + NADJ
*
IT = QS + NADJ
IQ = IT + NADJ * NK
IR = IQ + NADJ * NK
ista= ir + nadj
idel= ista+nadj*(ka-1)*6
is = idel+nadj*nk
IW = Is + NADJ*nk
IPS = IW + NADJ
IKCL = IPS + NADJ
IMAX = IKCL + NADJ - 1
*
* ALLOCATION DU CHAMP DE TRAVAIL G
c IF(ITER.EQ.1) THEN
c ALLOCATE ( G(IMAX) )
c ENDIF
*
CALL VGATHR(G(IT),NADJ,T,NDIM,NK,F)
CALL VGATHR(G(IQ),NADJ,Q,NDIM,NK,F)
CALL VGATHR(G(ista),NADJ,stawsj,N,(ka-1)*6,F)
CALL VGATHR(G(Idel),NADJ,delwetj,N,NK,F)
CALL VGATHR(G(Is),NADJ,s,N,NK,F)
CALL GATHER(NADJ,G(IR),R,F)
CALL GATHER(NADJ,G(IKCL),KCL,F)
CALL GATHER(NADJ,G(IW),W(1,KREP),F)
CALL GATHER(NADJ,G(IPS),PS,F)
*
CALL MCONADJ2 ( G(IT) , G(IQ) , G(IR) , G(IW) , G(IPS) ,
X G(IKCL) , G(iSTA) , G(iDEL) , G(iS) ,
Y G(DQ) , G(DT) , G(H) , G(HS) , G(P) , G(QS) ,
Z NN , ITER , NADJ , NK ,
% KA, NADJ, SATUCO)
*
CALL SCATTER(NADJ,R,F,G(IR))
CALL VSCATR(G(IT),NADJ,T,NDIM,NK,F)
CALL VSCATR(G(IQ),NADJ,Q,NDIM,NK,F)
*
NN = 0
DO 32 I = 1,NADJ
IF ( G(DQ+I-1) .GT. 0 ) THEN
NN = NN + 1
F(NN) = F(I)
END IF
32 CONTINUE
*
IF ( ITER .EQ. 2 ) THEN
RDOT = 0
DO 33 I = 1,NADJ
IF ( G(QS+I-1) .GT. 0 ) RDOT = RDOT + 1
33 CONTINUE
END IF
*
IF(ITER.LE.MAXADJ) ITADJ(ITER) = NN
IF(ITER.EQ.MAXADJ) PRINT *,(G(IKZ),IKZ=1,NADJ)
*
NADJ = NN
*
GOTO 25
*
ENDIF
*
*
35 DO 40 J=1,N
R(J) = -1. * DEPTH * PS(J) * R(J)/TAU
40 CONTINUE
NSUPS = NSUPS + RDOT
*
DO 50 K=1,NK
DO 50 J=1,N
50 Q(J,K) = MAX( Q(J,K) , 0.0 )
*
*
RETURN
CONTAINS
#include "fintern90.cdk"
END