!-------------------------------------- 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 PHY_DEBU
integer function phy_debu (n,nk,dimbuse,dimbusd,dimbusp,dimbusv, 1,10
$ prout,rdradf_d)
#include "impnone.cdk"
logical prout
integer n,nk,dimbuse,dimbusd,dimbusp,dimbusv
external rdradf_d
*
*Author
* B. Bilodeau (Spring 1994)
*
*Revisions
* 001 M. Gagnon (Jul 95) - Added validation code for radniv
* 002 M. Desgagne (Nov 95) - Unified physics interface
* 003 L. Lefaivre (Nov 95/Feb 96) - Initialize ETRMIN and Z0MIN
* with values passed from dynamics
* 004 B. Dugas (Sep 96) - Coherence check between CLIMAT, RADFIX
* 005 G. Pellerin (Nov 95) - Added switches for deep convection
* KUOSTD,KUOSYM,KUOSUN with CONSUN
* 006 G. Pellerin (Nov 96) - Insert common tables for RAS option
* 007 B. Bilodeau (Apr 97) - Insert comdeck for CLASS
* 008 M. Desgagne (Spring 97) - Microphysics
* 009 B. Bilodeau (Jan 98) - Connect FCP and KFC with CONSUN
* 010 Y. Delage (Feb 98) - Addition of HMIN in "surfcon.cdk"
* 011 B. Bilodeau (Jun 98) - RADFILES and FOMICHEV
* 012 M. Desgagne (Oct 98) - call back to rdradf_d (from dynamics)
* 013 B. Bilodeau (Dec 98) - New "entry" bus
* 014 M. Desgagne (Dec 98) - Correct bug in calculation of moyhr
* 015 B. Bilodeau (Oct 99) - CW_RAD
* 016 B. Bilodeau (Oct 2000) - Move consistency tests at the end
* of the subroutine to correct FOMIC-REDUC bug
* 017 B. Bilodeau (Nov 2000) - Replace call to radini, turbini,
* gwdini and convini by call to phy_ini.
* Eliminate call to ptcalc.
* 018 S. Belair and B. Bilodeau (May 2001)
* - New density for fresh snow.
* 019 B. Bilodeau (Mar 2001) - OPTIX
* 020 B. Dugas (Jan 2002) - FOMIC and REDUC are now compatible
* 021 B. Bilodeau (Mar 2002) - Correct bug in calculation of nspliti
* and add dzsedi.cdk
* 022 A-M. Leduc (Jan 2003) - SHLCVT becomes SHLCVT(1) or SHLCVT(2)
* 023 B. Dugas (Feb 2003) - share small_sedimentation_dt and
* cldopt_mode comdecks with SAVE_OPTIONS
* 024 B. Bilodeau (Feb 2003) - AS2, BETA2 and KKL2 parameters
* Remove ALAT and BLAT
* 025 B. Dugas (Mar 2003) - Add STRATOS parametre
* 026 A. Plante (June 2003) - Add VARMTN (mountains.cdk)
* 027 B. Dugas (July 2003) - Add CRITLAC parametre
* 028 A. Plante (sep 2003) - Add key pcptype rule
* 029 Y. Delage (Apr 2004) - Reactivate land surface module CLASS
* - Default values of parameters in common SURFCON
* now defined in surfcon_ini.cdk
* 030 B. Bilodeau (Jul 2004) - Add Z0TLAT
* 031 L. Spacek (Aug 2004) - cloud clean-up
* elimination of ISTCOND=2,6,7,8 ICONVEC=4
* 032 B. Bilodeau (Oct 2004) - Add protective code for dzsedi
*
* 033 S. Valcke (Apr 2005) - COUPLING and IMPFLX incompatible
* 034 B. Dugas (Aug 2005) - Initialize commons in Block DATA PHYDEBU4_DATA
* 035 D. Talbot (may 2006) - Add option cccmarad
* 036 J. Cole (May 2006) - Implement the ISCCP cloud simulator
* 037 B. Dugas (Dec 2006) - Remove all reference to DEBUT
* 038 J. Milbrandt (Dec 2006) - Added options for 5 versions of Milbrandt-Yau scheme
* 039 M. Desgagne (July 2006) - Revised interface. Change name to phy_debu.
* 039 B. Bilodeau (Feb 2007) - Cleanup and creation of check_options
* 040 M. Desgagne (Mar 2008) - optional ozone file
* 041 A-M. Leduc (Feb 2009) - add TRIGLAT
*
*Object
* initialization of the physics at the beginning
* of each execution of the model
*
*Arguments
* - Input -
* N horizontal dimension
* NK vertical dimension
*
* - Output -
* DIMBUSE dimension of the entry memory bus
* DIMBUSD dimension of the dynamics memory bus
* DIMBUSP dimension of the physics " "
* DIMBUSV dimension of the volatile " "
*
* - Input -
* prout logical switch to print on stdout
* rdradf_d call back routine from the dynamics to manage the file
*
*Notes
* phy_debu does the following :
* 1) it initializes a few constants necessary
* for the execution of the physics package.
* 2) it reads the radiation files if necessary.
* 3) it constructs the 3 main buses dictionaries.
*
*MODULES
EXTERNAL PHY_DEBU_DATA
*
**
#include "phy_master_ctrl.cdk"
#include "surfcon.cdk"
#include "acmcon.cdk"
#include "consphy.cdk"
#include "clefcon.cdk"
#include "machcon.cdk"
#include "scfrst.cdk"
#include "buses.cdk"
#include "options.cdk"
#include "sedipara.cdk"
#include "nbvarsurf.cdk"
#include "dimsurf.cdk"
#include "workspc.cdk"
*
#include "tables.cdk"
#include "dzsedi.cdk"
*
character varenv*512, fichozo*64, fichrad*64, sousrep*64, dumc*16
*
integer err, noptions_c
character*16 options_character(1)
*
integer i,k,courant(14),jour,mois,is1,is2,nv
integer maxsloflux
real*8 heure
logical okinit
*
integer espir,espredu,espsurf,espvis
REAL PTOP,dt0,dti0
*
EQUIVALENCE (OPTIONS_CHARACTER, OPTIONS_CHARACTER_FIRST(1))
!
! CALL TO EXTERNAL SUBROUTINE TO GENERATE CLOUD TABLE
external TABULATE_XCW
!
! CALL TO READ IN COMMON BLOCKS FOR ISCCP SIMULATOR
! PUT DATA IN MODULE LATER
external READ_ISCCPDATA
*
save okinit
data okinit/.false./
data varenv/'AFSISIO'/, sousrep/'/datafiles/constants/'/
*
* PTOP SERT AU CALCUL DES TABLES POUR LE SCHEMA RAS
DATA PTOP/0.0/
SAVE PTOP
*
*---------------------------------------------------------------------
*
* DEFINITION DE CODES DE CONTROLE
* - - - - - - - - - - - - - - - -
*
phy_debu = -1
if (phy_init_ctrl.ne.1001) then
! phy_init must be called before phy_debu
if (prout) write (6,2010)
goto 777
endif
phy_init_ctrl= 1002
if ((date(14).eq.0).or.(delt.eq.0)) then
if (prout) write (6,2020)
goto 777
endif
*
*
* INITIALISATION DE VARIABLES POUR CLEF
* - - - - - - - - - - - - - - - - - - -
*
#include "surfcon_ini.cdk"
AS = AS2
BETA = BETA2
ETRMIN = ETRMIN2
Z0MIN = Z0MIN2
EXPLIM = 75.
TANLIM = EXP(12. * ALOG(2.))
*
*
* CONSTANTES NUMERIQUES DANS LA FERMETURE DU MODELE CLEF
* - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* REF : THERRY ET LACARRERE
* ANDRE ET AL.
* BOUGEAULT
* MAILHOT ET BENOIT , JAS 1982
* WYNGAARD ET AL.
*
CLEFC1 = 3.75/1.75
CLEFC4 = 4.5
CLEFC6 = 4.85
CLEFC7 = 1.0-0.125*CLEFC6
CLEFC8 = 6.5
CLEFCB = 0.4
CLEFAE = 3.0*CLEFC4/CLEFC8
*
RIMB = 1.0 / RGASD
*
*
* INITIALISATION DE CONSTANTES POUR LE SCHEME DE MANABE
* - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
*
DEPTH = 1.0/(RAUW * GRAV)
*
* PARAMETRES UTILISES DANS LE SOUS-PROGRAMME MCONADJ
*
HC = HC2
HF = HF2
HM = HM2
*
IF ( MOIADJ.NE.1 ) MOIADJ = 0
ITRMAX = 4*LEVMAX
HMHCMIN = MIN( HC , HM )
HCMTOL = HC - TOL
*
* PARAMETRE UTILISE DANS L'INSTRUCTION FONCTION CHIC
* GAMMA CRITIQUE = CHIC( H ) * GAMMA SATURATION
*
* CHIC( H ) = CVMGT( HCI * ( H - HC ) , 1.0 , H.LT.1.0 )
*
HCI = 1.0
IF ( HC.NE.1.0 ) HCI = 1.0/( 1.0 - HC )
*
* PARAMETRE UTILISE DANS L'INSTRUCTION FONCTION CRIRLH
* SI ITER = 1 , HS ( HUMIDITE RELATIVE DE CRITIQUE DE SATURATION )
* = CRIRLH( H )
*
* CRIRLH( H ) = MIN( H , 1.0 ) - AA * ( MIN( H , 2.0 - H ) - HM )**3
*
AA = 0.0
IF( HM.LT.1.0 ) AA = 1.0/(6.0 * (1.0 - HM) ** 2)
*
*
* RADIATION
* - - - - -
*
* reduction des niveaux pour les calculs radiatifs
* pour option "NEWRAD"
*
NV = 0
do i=1,LEVMAX
if (radnivl(i).eq.0) goto 100
if (radnivl(i).lt.0.or.radnivl(i).gt.nk) then
if (prout) write(6,1600) 'WRONG LEVELS IN THE LIST'
goto 777
endif
NV = NV+1
enddo
*
100 if (NV.gt.0 .and. NV.lt.nk) then
do i=NV,1,-1
radnivl(i+1) = radnivl(i)
enddo
radnivl(1) = NV
else if (NV.eq.nk) then
radnivl(1) = 0
else if (NV.gt.nk) then
if (prout) write(6,1600) 'TOO MANY LEVELS IN THE LIST'
goto 777
end if
*
IF (RADNIVL(1) .EQ. 0 .OR. RADNIVL(1).EQ.NK) THEN
*
REDUC = .FALSE.
*
ELSE
*
REDUC = .TRUE.
*
if( radnivl(2) .ne. 1 ) then
if (prout) write(6,1600) 'THE LIST MUST BEGIN WITH LEVEL 1'
goto 777
endif
*
do i=2,radnivl(1)
if( radnivl(i) .ge. radnivl(i+1) ) then
if (prout) write(6,1600) 'THE LIST MUST BE SORTED IN ASCENDING ORDER'
goto 777
endif
enddo
*
ENDIF
*
* lecture des tableaux de radiation
*
if (radia.eq.'NEWRAD' .OR. radia.eq.'CCCMARAD') then
*
if (.not. okinit) then
*
ozone_file_S= 'ozone_clim.fst'
fichrad = 'rad_table.fst'
call litozon2 (ozone_file_S, rdradf_d, 3)
call litblrad2 (fichrad , rdradf_d, 3)
okinit = .true.
!
if (simisccp) then
!
! compute the table needed to generate variability
! for the stochastic cloud generator
!
call TABULATE_XCW()
!
! read in data blocks for ISCCP simulator code
!
call READ_ISCCPDATA()
!
endif
!
endif
endif
*
*
* initialisation des common block de CLASS
* - - - - - - - - - - - - - - - - - - - -
*
if (schmsol.eq.'CLASS') then
*
* pour initialiser dans CLASS les constantes contenues
* dans les common CONSPHY et SURFCON
call set_class_const()
*
* pour initialiser les constantes propres a CLASS
call classd(delt)
*
endif
*
* calcul des tableaux de pkappa et qsatvp pour RAS
* - - - - - - - - - - - - - - - - - - - - - - - -
*
* pkappa: fonction d'Exner
* qsatvp: pression de vapeur saturante (mb)
*
if (CONVEC .eq. 'RAS') then
call ntables (pkappa,qsatvp,npkappa,nqsatvp,cappa,max(ptop,.01))
call iniras
endif
*
if (dzsedi.lt.0..or.dzsedi.gt.500.) then
if (prout) write(6,1500)
goto 777
endif
*
if (istcond.ge.9) then
*
* the following comdeck is shared with SAVE_OPTIONS
*
#include "small_sedimentation_dt.cdk"
*
endif
*
*
* check if z0tlat is valid and change units
* - - - - - - - - - - - - - - - - - - - - -
*
if ( (min(z0tlat(1),z0tlat(2)).LT. 0.0) .or.
$ (max(z0tlat(1),z0tlat(2)).GT.90.0) .or.
$ (z0tlat(1).GT.z0tlat(2)) ) then
if (prout) write(6,2100)
goto 777
else
* conversion from degrees to radians
z0tlat(1) = z0tlat(1) * PI/180.
z0tlat(2) = z0tlat(2) * PI/180.
endif
*
*
* check if triglat is valid and change units
* - - - - - - - - - - - - - - - - - - - - -
*
if ( (min(triglat(1),triglat(2)).LT. 0.0) .or.
$ (max(triglat(1),triglat(2)).GT.90.0) .or.
$ (triglat(1).GT.triglat(2)) ) then
if (prout) write(6,2110)
goto 777
else
* conversion from degrees to radians
triglat(1) = triglat(1) * PI/180.
triglat(2) = triglat(2) * PI/180.
endif
*
* CONSTRUCTION OF THE 4 MAIN BUSES DICTIONARIES:
* - - - - - - - - - - - - - - - - - - - - - - -
* BUSENT, BUSDYN, BUSPER and BUSVOL
* - - - - - - - - - - - - - - - - -
*
if (schmurb.eq.'NIL') then
nsurf = max (indx_soil,indx_glacier,indx_water,
+ indx_ice,indx_agrege) - 1
else
nsurf = max (indx_soil,indx_glacier,indx_water,
+ indx_ice,indx_agrege,indx_urb) - 1
endif
*
call phy_ini (n,nk)
buslck = .true.
dimbuse = enttop
dimbusd = dyntop
dimbusp = pertop
dimbusv = voltop
*
* initialisation des pointeurs pour le "minibus de surface"
call iniptsurf(n,nk,prout)
*
*
* Espace de travail commun de la physique
* - - - - - - - - - - - - - - - - - - - -
*
* espace requis pour les processus de surface
espsurf = 4*surfesptot*n + 12*n + 4*nvarsurf
*
* espace requis pour l'option de reduction des niveaux
if (reduc) then
espredu = 7*n*radnivl(1) + 12*n*nk + 3*n
else
espredu = 12*n*nk + 3*n
endif
*
* espace necessaire au scheme de rad. solaire
espvis = 47*n*(nk+2) + espredu
*
* espace necessaire au scheme de rad. infrarouge
espir = n*(5+ (nk+1)*(18+ 3*(nk+1))) + espredu
* memoire requise pour l'espace de travail total
espwork = max(espvis,espir,espsurf)
*
*
* Calcul de moyhr
* - - - - - - - -
*
* moyhr est la periode de moyennage des diagnostics.
* conversion : nombre d'heures --> nombre de pas de temps.
moyhr = nint (moyhr * 3600./delt)
*
phy_debu = 1
777 if (phy_debu.gt.0) then
phy_init_ctrl = 1003
else
if (prout) write (6,2000)
endif
*
*
1500 FORMAT ( ' *****************************************',
+ / ' *****************************************',
+ / ' * *',
+ / ' ***** ABORT ***** ABORT ***** ABORT *****',
+ / ' * *',
+ / ' * S/R PHYDEBU4: *',
+ / ' * *',
+ / ' * DZSEDI HAS INCORRECT VALUE *',
+ / ' * *',
+ / ' * *',
+ / ' *****************************************',
+ / ' *****************************************')
*
1600 FORMAT( ' *****************************************************',
+ / ' *****************************************************',
+ / ' * *',
+ / ' * S/R PHY_DEBU, OPTION RADNIVL: *',
+ / ' * ',A,
+ / ' * *',
+ / ' *****************************************************',
+ / ' *****************************************************')
*
2000 FORMAT (' --- ABORT CODE FROM S/R PHY_DEBU ---'/)
2010 FORMAT (/' SUBROUTINE PHY_INIT MUST BE CALLED BEFORE PHY_DEBU')
2020 FORMAT (/' VARIABLES: date,delt NOT INITIALIZED')
2100 FORMAT ( ' *****************************************',
+ / ' *****************************************',
+ / ' * *',
+ / ' ***** ABORT ***** ABORT ***** ABORT *****',
+ / ' * *',
+ / ' * SUBROUTINE PHY_DEBU: *',
+ / ' * *',
+ / ' * WRONG SPECIFICATION OF Z0TLAT *',
+ / ' * *',
+ / ' * *',
+ / ' *****************************************',
+ / ' *****************************************')
2110 FORMAT ( ' *****************************************',
+ / ' *****************************************',
+ / ' * *',
+ / ' ***** ABORT ***** ABORT ***** ABORT *****',
+ / ' * *',
+ / ' * SUBROUTINE PHY_DEBU: *',
+ / ' * *',
+ / ' * WRONG SPECIFICATION OF TRIGLAT *',
+ / ' * *',
+ / ' * *',
+ / ' *****************************************',
+ / ' *****************************************')
*
*
*
*----------------------------------------------------------------------
return
end
BLOCK DATA PHY_DEBU_DATA
*
#include "acmcon.cdk"
#include "buses.cdk"
#include "comphy.cdk"
#include "isbapar.cdk"
#include "mountains.cdk"
#include "surfacepar.cdk"
#include "surfcon.cdk"
*
* POUR INITIALISER LE COMMON ACMCON
data lheat,moiadj,moiflx,itret/1,1,1,1/
DATA TOL / 0.01 /
DATA TRESHLD / 0.01 /
*
integer maxbus2
parameter (maxbus2=2*maxbus)
*
* POUR INITIALISER LES COMMONs de buses.cdk
data enttop,dyntop,pertop,voltop /4*0/
data entspc,dynspc,perspc,volspc /4*0/
data entnm,dynnm,pernm,volnm /maxbus2*' ',maxbus2*' ',
+ maxbus2*' ',maxbus2*' '/
data entdc,dyndc,perdc,voldc /maxbus*' ' ,maxbus*' ',
+ maxbus*' ' ,maxbus*' ' /
data entpar,dynpar,perpar,volpar /
+ maxbus*0,maxbus*0,maxbus*0,maxbus*0,
+ maxbus*0,maxbus*0,maxbus*0,maxbus*0,
+ maxbus*0,maxbus*0,maxbus*0,maxbus*0,
+ maxbus*0,maxbus*0,maxbus*0,maxbus*0,
+ maxbus*0,maxbus*0,maxbus*0,maxbus*0,
+ maxbus*0,maxbus*0,maxbus*0,maxbus*0,
+ maxbus*0,maxbus*0,maxbus*0,maxbus*0,
+ maxbus*0,maxbus*0,maxbus*0,maxbus*0
+ /
data buslck /.false./
*
* POUR INITIALISER LE COMMON COMPHY
DATA CEVAP ,CMELT, CCCTIM
+ /1.2E-4,2.4E+4, 1800./
*
* POUR INITIALISER LE COMMON ISBAPAR
DATA ANSMAX,TODRY,RHOMIN,RHOSDEF,WCRN /0.80, 0.008, 0.05, 0.15, 10.0/
*
* POUR INITIALISER LE COMMON mountains
DATA VARMTN/0/
*
* POUR INITIALISER LE COMMON SURFACEPAR
DATA CRITMASK,CRITSNOW,CRITWATER,CRITEXTURE,MINICEDP,CRITLAC
+ / 0.001 , 0.0001 , 0.001 , 0.1 , 0.05 , 0.01 /
*
* POUR INITIALISER LE COMMON SURFCON
DATA ANGMAX / 0.85 /
*
END BLOCK DATA PHY_DEBU_DATA