!copyright (C) 2001 MSC-RPN COMM %%%RPNPHY%%%
subroutine iniptsurf(ni,nk,prout) 1
*
#include "impnone.cdk"
*
integer ni, nk
logical prout
*
*Author
* B. Bilodeau (Sept 1999)
*
*Revisions
* 001 B. Bilodeau (Nov 2000) - New comdeck sfcbus.cdk
* 002 B. Bilodeau (Feb 2004) - Revised logic to facilitate the
* addition of new types of surface
*
*
*Object
* Initialization of common blocks used in the surface package
*
*Arguments
*
* - Input -
* NI horizontal dimension
* NK vertical dimension
* PROUT switch for printing some informative message
*
*
*Notes
*
*IMPLICITES
*
*
*MODULES
*
***
*
#include "options.cdk"
*
#define DCLCHAR
#include "phy_macros_f.h"
#include "sfcbus.cdk"
*
#include "nbvarsurf.cdk"
character*8 nom
integer pointeurs(0:1)
character*8 nomsurf (0:1)
equivalence (sfcbus_i_first(0),pointeurs(0))
equivalence (sfcbus_c_first(0),nomsurf (0))
*
#include "dimsurf.cdk"
#include "buses.cdk"
*
integer i, j, l, m
integer nb_agrege, nb_glaciers, nb_water, nb_ice
*
parameter (nb_agrege=22)
character*8 agrege_out(nb_agrege)
*
* les variables de sortie du module "soils" ont preseance
* sur celles de tous les autres schemas, sauf exceptions
* contenues dans les listes plus bas
*
* liste des variables de surface a agreger
data agrege_out /
*
* ces variables sont moyennees lineairement
$ 'ALFAQ' , 'ALFAT' , 'ALVIS' , 'BM' , 'BT' ,
$ 'FC' , 'FTEMP' , 'FV' , 'FVAP' , 'HST' ,
$ 'ILMO' , 'QSURF' , 'QDIAG' , 'SNODP' , 'TDIAG' ,
$ 'TSURF' , 'UE2' , 'UDIAG' , 'VDIAG' ,
*
* le flux infrarouge emis par la surface, qui est
* proportionnel a TSRAD**4, est moyenne lineairement
$ 'TSRAD' ,
*
* on prend la moyennne logarithmique des longueurs de rugosite
$ 'Z0' , 'Z0T'
*
$ /
*
*
* liste des variables de sortie du module "glaciers"
parameter (nb_glaciers=1)
character*8 glaciers_out(nb_glaciers)
data glaciers_out /
*
$ 'TGLACIER'
$ /
*
*
* liste des variables de sortie du module "water"
parameter (nb_water=1)
character*8 water_out(nb_water)
data water_out /
*
$ 'TWATER'
$ /
*
*
* liste des variables de sortie du module "ice"
parameter (nb_ice=2)
character*8 ice_out(nb_ice)
data ice_out /
*
$ 'ICEDP' , 'TMICE'
*
$ /
*
nvarsurf = COMPHY_SIZE(sfcbus)
*
* verification de la dimension du common
if (nvarsurf.gt.maxvarsurf) then
write(6,1060) nvarsurf
call qqexit(1)
endif
*
* conversion des noms de minuscule a majuscule, si necessaire
do j=1,nvarsurf
call low2up(nomsurf(j),nom)
nomsurf(j) = nom
end do
*
* initialisations
do j=1,nvarsurf
agg (j) = 0
quel_bus (j) = 0
pointeurs(j) = 0
ptdebut (j) = 0
end do
*
do m=1,mulmax
do j=1,nvarsurf
statut(j,m) = 0
end do
end do
*
*
* exploration du bus dynamique
*
do i=1,dyntop
do j=1,nvarsurf
if (nomsurf(j).eq.dynnm(i,1)) then
quel_bus (j) = 1
ptdebut (j) = dynpar(i,1)
mul (j) = dynpar(i,6)
niveaux (j) = dynpar(i,7)
if (mul(j).gt.mulmax) then
write(6,1000) nomsurf(j)
call qqexit(1)
endif
endif
end do
end do
*
* exploration du bus permanent
*
do i=1,pertop
do j=1,nvarsurf
if (nomsurf(j).eq.pernm(i,1)) then
quel_bus (j) = 2
ptdebut (j) = perpar(i,1)
mul (j) = perpar(i,6)
niveaux (j) = perpar(i,7)
if (mul(j).gt.mulmax) then
write(6,1000) nomsurf(j)
call qqexit(1)
endif
if (nomsurf(j).eq.'TSRAD') then
tsrad_i = j
else if (nomsurf(j).eq.'Z0' ) then
z0_i = j
else if (nomsurf(j).eq.'Z0T' ) then
z0t_i = j
endif
endif
end do
end do
*
* exploration du bus volatil
*
do i=1,voltop
do j=1,nvarsurf
if (nomsurf(j).eq.volnm(i,1)) then
quel_bus(j) = 3
ptdebut (j) = volpar(i,1)
mul (j) = volpar(i,6)
niveaux (j) = volpar(i,7)
if (mul(j).gt.mulmax) then
write(6,1000) nomsurf(j)
call qqexit(1)
endif
endif
end do
end do
*
*
surfesptot = 0
*
do j=1,nvarsurf
*
pointeurs(j) = j
*
surfesptot = surfesptot + mul(j)*niveaux(j)
*
*
* initialisation de la variable "statut",
* pour le controle des variables qui seront
* soit agregees (moyennees), soit sorties
* directement d'un bus des bus de surface
* correspondant a chacun des 4 types de surface :
* statut = 1 --> bus de "sol" vers bus permanent ou volatil
* = 2 --> bus de "glaciers" " " " " "
* = 3 --> bus de "water" " " " " "
* = 4 --> bus de "ice" " " " " "
* = 5 --> moyenne des 4 " " " " "
* voir comdeck "indx_sfc.cdk"
*
* variables agregees
do l=1,nb_agrege
*
if (agrege_out(l).eq.nomsurf(j)) then
*
* cas no 1 : variables agregees de dimension 1
if (mul(j).eq.1) then
*
agg (j ) = 1
statut(j,1) = indx_agrege
*
* cas no 2 : variables agregees pour lesquelles on conserve
* non seulement la moyenne mais aussi les valeurs associees
* a chaque type de surface
else if (mul(j).eq.(nsurf+1)) then
*
agg (j) = indx_agrege
statut(j,indx_agrege) = indx_agrege
statut(j,indx_soil ) = indx_soil
statut(j,indx_glacier) = indx_glacier
statut(j,indx_water ) = indx_water
statut(j,indx_ice ) = indx_ice
*
else if (mul(j).gt.1.and.mul(j).ne.(nsurf+1)) then
*
write(6,1010) nomsurf(j)
call qqexit(1)
*
endif
*
endif
*
end do
*
* variables de sortie du module "glaciers"
do l=1,nb_glaciers
if (glaciers_out(l).eq.nomsurf(j)) then
*
* Tous les "niveaux" de la variable sont
* assignes au module glaciers
do m=1,mul(j)
statut(j,m ) = indx_glacier
end do
*
endif
100 end do
*
* variables de sortie du module "water"
do l=1,nb_water
if (water_out(l).eq.nomsurf(j)) then
*
* Tous les "niveaux" de la variable sont
* assignes au module water
do m=1,mul(j)
statut(j,m ) = indx_water
end do
*
endif
200 end do
*
* variables de sortie du module "ice"
do l=1,nb_ice
if (ice_out(l).eq.nomsurf(j)) then
*
* Tous les "niveaux" de la variable sont
* assignes au module ice
do m=1,mul(j)
statut(j,m ) = indx_ice
end do
*
endif
300 end do
*
* les autres variables seront transferees du module "soils"
do m=1,mul(j)
if (statut(j,m).eq.0) statut(j,m) = indx_soil
end do
*
end do
*
if (prout) then
*
print *,' '
write(6,1020)
write(6,1030) 'SOIL ', indx_soil
write(6,1030) 'GLACIERS ', indx_glacier
write(6,1030) 'WATER ', indx_water
write(6,1030) 'MARINE ICE ', indx_ice
if (agregat) then
write(6,1030) 'AGGREGATED VALUE', indx_agrege
else
write(6,1030) 'COMPOSITE VALUE', indx_agrege
write(6,1040) '--> NO AGGREGATION IS PERFORMED <--'
endif
write(6,1050)
endif
*
1000 format ( ' *****************************************',
+ / ' *****************************************',
+ / ' * *',
+ / ' ***** ABORT ***** ABORT ***** ABORT *****',
+ / ' * *',
+ / ' * S/R INIPTSURF: MULMAX EXCEEDED FOR *',
+ / ' * VARIABLE = ', A8, ' *',
+ / ' * *',
+ / ' *****************************************',
+ / ' *****************************************')
*
*
1010 format ( ' *****************************************',
+ / ' *****************************************',
+ / ' * *',
+ / ' ***** ABORT ***** ABORT ***** ABORT *****',
+ / ' * *',
+ / ' * S/R INIPTSURF: MULTIPLICITY FACTOR *',
+ / ' * EXCEEDED FOR VARIABLE = ', A8, ' *',
+ / ' * *',
+ / ' *****************************************',
+ / ' *****************************************')
1020 FORMAT (2(1x,60('*')/),1x,'*',58(' '),'*'/
+ 1x,'*',(' TYPES OF SURFACE :'),37(' '),'*'/
+ ' *',3(' '),"----------------",39(' '),'*'/
+ 1x,'*',58(' '),'*')
1030 FORMAT (1x,'*',20(' '),A20,4(' '),I2,12(' '),'*'/
+ 1x,'*',58(' '),'*')
1040 FORMAT (1x,'*',10(' '),A36,4(' '),8(' '),'*'/
+ 1x,'*',58(' '),'*')
1050 FORMAT (2(1x,60('*')/)/)
*
1060 format ( ' *****************************************',
+ / ' *****************************************',
+ / ' * *',
+ / ' ***** ABORT ***** ABORT ***** ABORT *****',
+ / ' * *',
+ / ' * S/R INIPTSURF: *',
+ / ' * MAXVARSURF IS TOO SMALL. *',
+ / ' * MINIMUM VALUE : ',I6,' *',
+ / ' * SEE COMDECK NBVARSURF. *',
+ / ' * *',
+ / ' *****************************************',
+ / ' *****************************************')
*
return
end