Skip to content
Snippets Groups Projects
Commit 31b47ce0 authored by Gaelle DELAUTIER's avatar Gaelle DELAUTIER
Browse files

Gaelle 26/04/2018 : add MEGAN

parent a4f0e4d6
Branches
Tags
No related merge requests found
File added
!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!SFX_LIC for details. version 1.
! ###############################
SUBROUTINE COUPLING_MEGAN_n(MGN, CHI, GK, PEK, &
KYEAR, KMONTH, KDAY, PTIME, OTR_ML, &
KSLTYP, PPFT, PEF, &
PTEMP, PIACAN, PLEAFT, PRN_SUNLIT, PRN_SHADE, &
PWIND, PPRES, PQV, PSFTS)
! ###############################
!!
!!*** *BVOCEM*
!!
!! PURPOSE
!! -------
!! Calculate the biogenic emission fluxes upon the MEGAN code
!! http://lar.wsu.edu/megan/
!!
!! METHOD
!! ------
!!
!!
!! AUTHOR
!! ------
!! P. Tulet (LACy)
!!
!! MODIFICATIONS
!! -------------
!! Original: 25/10/2014
!! Modified: 06/07/2017, J. Pianezze, adaptation for SurfEx v8.0
!!
!! EXTERNAL
!! --------
!!
!! IMPLICIT ARGUMENTS
!! ------------------
!
USE MODD_MEGAN_n, ONLY : MEGAN_t
USE MODD_CH_ISBA_n, ONLY : CH_ISBA_t
USE MODD_ISBA_n, ONLY: ISBA_PE_t
USE MODD_SFX_GRID_n, ONLY: GRID_t
!
USE MODD_CSTS, ONLY : XAVOGADRO
!
#ifdef MNH_MEGAN
USE MODD_MEGAN
USE MODI_JULIAN
USE MODI_EMPROC
USE MODI_MGN2MECH
#endif
!
!------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
! -----------------
!
IMPLICIT NONE
!
TYPE(MEGAN_t), INTENT(INOUT) :: MGN
TYPE(CH_ISBA_t), INTENT(INOUT) :: CHI
TYPE(GRID_t), INTENT(INOUT) :: GK
TYPE(ISBA_PE_t), INTENT(INOUT) :: PEK
!
!* 0.1 declaration of arguments
!
INTEGER, INTENT(IN) :: KYEAR ! I current year (UTC)
INTEGER, INTENT(IN) :: KMONTH ! I current month (UTC)
INTEGER, INTENT(IN) :: KDAY ! I current day (UTC)
REAL, INTENT(IN) :: PTIME ! I current time since midnight (UTC, s)
LOGICAL, INTENT(IN) :: OTR_ML ! new radiation for leaves temperatures
!
REAL, DIMENSION(:), INTENT(IN) :: PTEMP ! I Air temperature (K)
REAL, DIMENSION(:,:),INTENT(IN) :: PIACAN ! I PAR (umol/m2.s)
REAL, DIMENSION(:), INTENT(IN) :: PLEAFT ! I Leaf temperature (K)
REAL, DIMENSION(:), INTENT(IN) :: PRN_SUNLIT! I Leaf RN
REAL, DIMENSION(:), INTENT(IN) :: PRN_SHADE ! I Leaf RN
REAL, DIMENSION(:), INTENT(IN) :: PWIND
REAL, DIMENSION(:), INTENT(IN) :: PPRES ! I Atmospheric pressure (Pa)
REAL, DIMENSION(:), INTENT(IN) :: PQV ! I Air humidity (kg/kg)
REAL, DIMENSION(:,:),INTENT(IN) :: PPFT, PEF
INTEGER, DIMENSION(:), INTENT(IN) :: KSLTYP
REAL, DIMENSION(:,:), INTENT(INOUT) :: PSFTS ! O Scalar flux in molecules/m2/s
#ifdef MNH_MEGAN
!* 0.1 Declaration of local variables
!
INTEGER, PARAMETER :: NROWS = 1
INTEGER :: ITIME ! Time of the day HHMMSS
INTEGER :: IDATE ! Date YYYYDDD
INTEGER :: IDAY ! julian day
REAL :: ZHOUR, ZMIN, ZSEC ! conversion ptime to itime format
REAL, DIMENSION(SIZE(PTEMP)) :: ZLAIC ! Current monthly LAI
REAL, DIMENSION(SIZE(PTEMP)) :: ZPFD ! Calculated PAR (umol/m2.s)
REAL, DIMENSION(SIZE(PTEMP)) :: ZLSUT ! Leaf on sun temperature (K)
REAL, DIMENSION(SIZE(PTEMP)) :: ZLSHT ! Leaf on shade temperature (K)
REAL, DIMENSION(SIZE(PTEMP)) :: ZRN
REAL, DIMENSION(SIZE(PTEMP)) :: ZCFNO ! NO correction factor
REAL, DIMENSION(SIZE(PTEMP)) :: ZCFNOG ! NO correction factor for grass
REAL, DIMENSION(N_MGN_SPC,SIZE(PTEMP)) :: ZCFSPEC ! Output emission buffer
REAL, DIMENSION(MGN%NVARS3D,SIZE(PTEMP)) :: ZFLUX ! Output emission megan flux
!
REAL :: ZDI ! Drought Index (0 normal, -2 moderate drought, -3 severe drought, -4 extreme drought)
REAL :: ZREC_ADJ ! Rain adjustment factor
REAL :: ZD_TEMP ! Daily temperature (K)
REAL :: ZD_PPFD ! Daily PAR (umol/m2.s)
!
INTEGER,DIMENSION(SIZE(PTEMP)) :: ISLTYP !Soil category (function of silt, clay and sand))
INTEGER :: JSV, JSM
!
! Input parameters
ZHOUR = FLOAT(INT(PTIME/3600.))
ZMIN = FLOAT(INT((PTIME - ZHOUR*3600) / 60.))
ZSEC = FLOAT(INT(PTIME - ZHOUR*3600. - ZMIN * 60.))
ITIME = INT(ZHOUR)*10000 + INT(ZMIN)*100 + ZSEC
IDAY = JULIAN(KYEAR, KMONTH, KDAY)
IDATE = KYEAR*1000 + IDAY
!
! current = previous pour le LAI, a modifier si CPHOTO=LAI (evolutif)
ZLAIC(:) = MIN(MAX(0.001,PEK%XLAI(:)),8.)
!
ZDI = MGN%XDROUGHT
ZREC_ADJ = MGN%XMODPREC
ZD_TEMP = MGN%XDAILYTEMP
ZD_PPFD = MGN%XDAILYPAR
!
ZCFNO = 0.
ZCFNOG = 0.
ZCFSPEC = 0.
!
ZPFD(:) = 0.
! Compute PAR from the entire canopy
DO JSM = 1,SIZE(PIACAN,2)
ZPFD(:) = ZPFD(:) + PIACAN(:, JSM)
END DO
! Test car PIACAN prends des valeurs non physiques au lever du soleil
WHERE (ZPFD(:) .GT. 2000.) ZPFD(:) = 0.
!
! compute sun and shade leaf temperature upon RN_SHADE and RN_SUNLIT
! thanks to D. Carrer
!
ZLSUT(:) = PTEMP(:) + 3.
ZLSHT(:) = PTEMP(:)
!
IF (OTR_ML) THEN
!
ZRN(:) = PRN_SUNLIT(:)**2 + PRN_SHADE(:)**2
!
WHERE ( ZRN(:).NE.0. )
! for sun leaves
ZLSUT(:) = PLEAFT(:) * PRN_SUNLIT(:) * (PRN_SUNLIT(:)+PRN_SHADE(:))/ZRN(:)
! for shade leaves
ZLSHT(:) = PLEAFT(:) * PRN_SHADE (:) * (PRN_SUNLIT(:)+PRN_SHADE(:))/ZRN(:)
END WHERE
!
END IF
!
! MEGAN : calcul des facteurs d'ajustement et de perte dans la canopée.
! ZCFSPEC: classe de sorties MEGAN (voir SPC_NOCONVER.EXT)
! 1: ISOP isoprene
! 2: MYRC myrcene
! 3: SABI sabinene
! 4: LIMO limonene
! 5: A_3CAR carene_3
! 6: OCIM ocimene_t_b
! 7: BPIN pinene_b
! 8: APIN pinene_a
! 9: OMTP A_2met_styrene + cymene_p + cymene_o + phellandrene_a + thujene_a + terpinene_a
! + terpinene_g + terpinolene + phellandrene_b + camphene + bornene + fenchene_a
! + ocimene_al + ....
! 10: FARN
! 11: BCAR
! 12: OSQT
! 13: MBO
! 14: MEOH
! 15: ACTO
! 16: CO
! 17: NO
! 18: BIDER
! 19: STRESS
! 20: OTHER
!
CALL EMPROC(ITIME, IDATE, ZD_PPFD, ZD_TEMP, ZDI, ZREC_ADJ, &
GK%XLAT, GK%XLON, ZLAIC, ZLAIC, PTEMP, &
ZPFD, PWIND, PPRES, PQV, KSLTYP, &
PEK%XWG(:,1), PEK%XTG(:,1), PPFT, &
CHI%LSOILNOX, ZCFNO, ZCFNOG, ZCFSPEC)
!
! MEGAN : calcul des flux d'émission
! Dans cette partie du programme les sorties des 20 catégories obtenues à l'issu de la partie
!EMPROC sont multipliées par les valeurs des facteurs d'émissions correspondants, puis converties
!en 150 espèces, et associées en différentes catégories chimiques en fonction du schéma de chimie
!atmosphérique choisi parmi RADM2, RACM, SAPRCII, SAPRC99, CBMZ, SAPRC99X,
!SAPRC99Q, CB05, CB6, SOAX .
!
CALL MGN2MECH(IDATE, GK%XLAT, PEF, PPFT, ZCFNO, ZCFNOG, ZCFSPEC, &
MGN%NSPMH_MAP, MGN%NMECH_MAP, MGN%XCONV_FAC, &
MGN%LCONVERSION, ZFLUX)
!
! Conversion ZFLUX from MEGAN mole/m2/s into molec/m2/s
ZFLUX(:,:) = ZFLUX(:,:) * XAVOGADRO
!
! Case of the same species between megan and mesonh
DO JSV=1, SIZE(CHI%SVI%CSV)
DO JSM=1, MGN%NVARS3D
IF (TRIM(CHI%SVI%CSV(JSV)) == TRIM(MGN%CVNAME3D(JSM))) THEN
PSFTS(:,JSV) = PSFTS(:,JSV) + ZFLUX(JSM,:)
END IF
END DO
END DO
!
! Case of special treatment : ReLACS 1, 2, 3 scheme or CACM scheme
! Megan conversion is upon SOAX species
IF ( TRIM(MGN%CMECHANISM)=="RELACS" ) THEN
PSFTS(:,MGN%NBIO ) = PSFTS(:,MGN%NBIO ) + ZFLUX(MGN%NISOPRENE,:) + ZFLUX(MGN%NTRP1,:)
ENDIF
!
IF ( TRIM(MGN%CMECHANISM)=="RELACS2") THEN
PSFTS(:,MGN%NORA1) = PSFTS(:,MGN%NORA1) + ZFLUX(MGN%NHCOOH,:)
PSFTS(:,MGN%NORA2) = PSFTS(:,MGN%NORA2) + ZFLUX(MGN%NCCO_OH,:)
PSFTS(:,MGN%NACID) = PSFTS(:,MGN%NACID) + ZFLUX(MGN%NRCO_OH,:)
END IF
!
IF ( TRIM(MGN%CMECHANISM)=="CACM" ) THEN
PSFTS(:,MGN%NACID) = PSFTS(:,MGN%NACID) + ZFLUX(MGN%NHCOOH,:) + ZFLUX(MGN%NCCO_OH,:) + ZFLUX(MGN%NRCO_OH,:)
ENDIF
IF ( TRIM(MGN%CMECHANISM)=="CACM".OR.TRIM(MGN%CMECHANISM)=="RELACS2" ) THEN
PSFTS(:,MGN%NISOP) = PSFTS(:,MGN%NISOP) + ZFLUX(MGN%NISOPRENE,:)
PSFTS(:,MGN%NBIOH) = PSFTS(:,MGN%NBIOH) + 0.75*ZFLUX(MGN%NTRP1,:)
PSFTS(:,MGN%NBIOL) = PSFTS(:,MGN%NBIOL) + 0.25*ZFLUX(MGN%NTRP1,:)
PSFTS(:,MGN%NKETL) = PSFTS(:,MGN%NKETL) + ZFLUX(MGN%NACET,:) + ZFLUX(MGN%NMEK,:)
PSFTS(:,MGN%NARAL) = PSFTS(:,MGN%NARAL) + ZFLUX(MGN%NBALD,:)
PSFTS(:,MGN%NETHE) = PSFTS(:,MGN%NETHE) + ZFLUX(MGN%NETHENE,:)
PSFTS(:,MGN%NALKL) = PSFTS(:,MGN%NALKL) + ZFLUX(MGN%NALK4,:)
PSFTS(:,MGN%NALKM) = PSFTS(:,MGN%NALKM) + 0.5*ZFLUX(MGN%NALK5,:)
PSFTS(:,MGN%NALKH) = PSFTS(:,MGN%NALKH) + 0.5*ZFLUX(MGN%NALK5,:)
PSFTS(:,MGN%NAROH) = PSFTS(:,MGN%NAROH) + 0.5*ZFLUX(MGN%NARO1,:)
PSFTS(:,MGN%NAROL) = PSFTS(:,MGN%NAROL) + 0.5*ZFLUX(MGN%NARO1,:)
PSFTS(:,MGN%NAROO) = PSFTS(:,MGN%NAROO) + ZFLUX(MGN%NARO2,:)
PSFTS(:,MGN%NOLEL) = PSFTS(:,MGN%NOLEL) + 0.5*ZFLUX(MGN%NOLE1,:)
PSFTS(:,MGN%NOLEH) = PSFTS(:,MGN%NOLEH) + 0.5*ZFLUX(MGN%NOLE1,:)
END IF
!
!
#endif
END SUBROUTINE COUPLING_MEGAN_n
This diff is collapsed.
!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!SFX_LIC for details. version 1.
! ####################
MODULE MODD_MEGAN_SURF_FIELDS_n
! ####################
!
!!**** *MODD_MEGAN_SURF_FIELDS* - declaration of megan physiographic data arrays
!!
!! PURPOSE
!! -------
! The purpose of this declarative module is to specify the
! megan physiographic data arrays.
!
!!
!! AUTHOR
!! ------
!! P. Tulet & M. Leriche *LACy & LA*
!!
!! MODIFICATIONS
!! -------------
!! Original 06/2017
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
! ------------
!
!
USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
USE PARKIND1 ,ONLY : JPRB
!
IMPLICIT NONE
TYPE MEGAN_SURF_FIELDS_t
!
INTEGER :: NMEGAN_NBR
! ! number of megan pgd fields chosen by user
CHARACTER(LEN=3) , DIMENSION(:), POINTER :: CMEGAN_AREA
! ! areas where megan pgd fields are defined
! ! 'ALL' : everywhere
! ! 'SEA' : where sea exists
! ! 'LAN' : where land exists
! ! 'WAT' : where inland water exists
! ! 'NAT' : where natural or agricultural areas exist
! ! 'TWN' : where town areas exist
! ! 'STR' : where streets are present
! ! 'BLD' : where buildings are present
! !
CHARACTER(LEN=20), DIMENSION(:), POINTER :: CMEGAN_NAME
! ! name of the megan pgd fields (for information)
REAL, DIMENSION(:,:), POINTER :: XMEGAN_FIELDS
! ! megan pgd fields themselves
!
!-------------------------------------------------------------------------------
!
END TYPE MEGAN_SURF_FIELDS_t
CONTAINS
!
!
SUBROUTINE MEGAN_SURF_FIELDS_INIT(YMEGAN_SURF_FIELDS)
TYPE(MEGAN_SURF_FIELDS_t), INTENT(INOUT) :: YMEGAN_SURF_FIELDS
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (LHOOK) CALL DR_HOOK("MODD_MEGAN_SURF_FIELDS_N:MEGAN_SURF_FIELDS_INIT",0,ZHOOK_HANDLE)
NULLIFY(YMEGAN_SURF_FIELDS%CMEGAN_NAME)
NULLIFY(YMEGAN_SURF_FIELDS%CMEGAN_AREA)
NULLIFY(YMEGAN_SURF_FIELDS%XMEGAN_FIELDS)
YMEGAN_SURF_FIELDS%NMEGAN_NBR=0
IF (LHOOK) CALL DR_HOOK("MODD_MEGAN_SURF_FIELDS_N:MEGAN_SURF_FIELDS_INIT",1,ZHOOK_HANDLE)
END SUBROUTINE MEGAN_SURF_FIELDS_INIT
END MODULE MODD_MEGAN_SURF_FIELDS_n
!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!SFX_LIC for details. version 1.
! #####################
MODULE MODD_MEGAN_n
! ######################
!
!!
!! PURPOSE
!! -------
!
!
!
!!
!!** IMPLICIT ARGUMENTS
!! ------------------
!! None
!!
!
!! AUTHOR
!! ------
!! P. Tulet *LACy
!!
!! MODIFICATIONS
!! -------------
!! 16/07/2003 (P. Tulet) restructured for externalization
!! 24/05/2017 (J. Pianezze) adaptation for SurfEx v8.0
!------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
! ------------
!
!
USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
USE PARKIND1 ,ONLY : JPRB
!
IMPLICIT NONE
!
TYPE MEGAN_t
!
INTEGER :: NBIO, NALKA, NALKE, NARO, NCARBO, NETHE, NOLEL, NOLEH, &
NALKL, NALKM, NALKH, NAROH, NAROO, NAROL, NARAL, NSO, &
NARAC, NPAH, NALD2, NKETL, NKETH, NMEOH, NETOH, NALCH, &
NISOP, NBIOL, NBIOH, NMTBE, NMVK, NMCR, NMGLY, NISO, &
NCH4, NETH, NHC3, NHC5, NHC8, NOL2, NOLI, NOLT, NALD, &
NKET, NTOL, NHCHO, NORA1, NORA2, NAPI, NLIM, NCO, &
NSO2, NNO, NHNO3, NNO2, NNR, N3CAR, NACTA, NACTO, &
NAPIN, NFORM, NBPIN, NMYRC, NOCIM, NOMTP, NSABI, &
NISP, NTRP, NXYLA, NCG5, NSQT, NTOLA, NCG6, NCG4, &
NISOPRENE, NTRP1, NACET, NMEK, NHCOOH, NCCO_OH, &
NCCHO, NRCHO, NRCO_OH, NBALD, NETHENE, NALK4, NALK5, &
NARO1, NARO2, NOLE1, NACID
!
CHARACTER(LEN=16) :: CMECHANISM ! name of the MesoNH chemical scheme
CHARACTER(LEN=16) :: CMECHANISM2 ! name of the MEGAN scheme used for conversion
LOGICAL :: LCONVERSION ! flag for the MEGAN output species (speciation on scheme or not)
INTEGER :: NVARS3D, N_SCON_SPC ! number of megan and chemical scheme species
REAL :: XDROUGHT ! Drought Index
REAL :: XDAILYPAR ! Mean daily PAR
REAL :: XDAILYTEMP ! Mean daily temperature (K)
REAL :: XMODPREC ! Precipitation correction factor (megan)
REAL, POINTER, DIMENSION(:,:) :: XEF ! efficiency factor
REAL, POINTER, DIMENSION(:,:) :: XPFT ! PFT factor (veg type)
INTEGER, POINTER, DIMENSION(:) :: NSLTYP ! USDA soil number category
CHARACTER(LEN=16), POINTER, DIMENSION(:) :: CVNAME3D ! name of the scheme species
CHARACTER(LEN=16), POINTER, DIMENSION(:) :: CMECH_SPC ! name of the scheme species
INTEGER, POINTER, DIMENSION(:) :: NSPMH_MAP ! index map of the scheme species
INTEGER, POINTER, DIMENSION(:) :: NMECH_MAP ! index map the mecanisum species
REAL, POINTER, DIMENSION(:) :: XCONV_FAC ! conversion factor of species
REAL, POINTER, DIMENSION(:) :: XMECH_MWT ! molecular weight of species
REAL, POINTER, DIMENSION(:) ::XBIOFLX ! molecular weight of species
!
END TYPE MEGAN_t
CONTAINS
!
SUBROUTINE MEGAN_INIT(YMEGAN)
TYPE(MEGAN_t), INTENT(INOUT) :: YMEGAN
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (LHOOK) CALL DR_HOOK("MODD_MEGAN_n:MEGAN_INIT",0,ZHOOK_HANDLE)
NULLIFY(YMEGAN%XEF)
NULLIFY(YMEGAN%XPFT)
NULLIFY(YMEGAN%NSLTYP)
NULLIFY(YMEGAN%CVNAME3D)
NULLIFY(YMEGAN%CMECH_SPC)
NULLIFY(YMEGAN%NSPMH_MAP)
NULLIFY(YMEGAN%NMECH_MAP)
NULLIFY(YMEGAN%XCONV_FAC)
NULLIFY(YMEGAN%XMECH_MWT)
NULLIFY(YMEGAN%XBIOFLX)
YMEGAN%NBIO=0
YMEGAN%NALKA=0
YMEGAN%NALKE=0
YMEGAN%NARO=0
YMEGAN%NCARBO=0
YMEGAN%NETHE=0
YMEGAN%NOLEL=0
YMEGAN%NOLEH=0
YMEGAN%NALKL=0
YMEGAN%NALKM=0
YMEGAN%NALKH=0
YMEGAN%NAROH=0
YMEGAN%NAROO=0
YMEGAN%NAROL=0
YMEGAN%NARAL=0
YMEGAN%NSO=0
YMEGAN%NARAC=0
YMEGAN%NPAH=0
YMEGAN%NALD2=0
YMEGAN%NKETL=0
YMEGAN%NKETH=0
YMEGAN%NMEOH=0
YMEGAN%NETOH=0
YMEGAN%NALCH=0
YMEGAN%NISOP=0
YMEGAN%NBIOL=0
YMEGAN%NBIOH=0
YMEGAN%NMTBE=0
YMEGAN%NMVK=0
YMEGAN%NMCR=0
YMEGAN%NMGLY=0
YMEGAN%NISO=0
YMEGAN%NCH4=0
YMEGAN%NETH=0
YMEGAN%NHC3=0
YMEGAN%NHC5=0
YMEGAN%NHC8=0
YMEGAN%NOL2=0
YMEGAN%NOLI=0
YMEGAN%NOLT=0
YMEGAN%NALD=0
YMEGAN%NKET=0
YMEGAN%NTOL=0
YMEGAN%NHCHO=0
YMEGAN%NORA1=0
YMEGAN%NORA2=0
YMEGAN%NAPI=0
YMEGAN%NLIM=0
YMEGAN%NCO=0
YMEGAN%NSO2=0
YMEGAN%NNO=0
YMEGAN%NHNO3=0
YMEGAN%NNO2=0
YMEGAN%NNR=0
YMEGAN%N3CAR=0
YMEGAN%NACTA=0
YMEGAN%NACTO=0
YMEGAN%NAPIN=0
YMEGAN%NFORM=0
YMEGAN%NBPIN=0
YMEGAN%NMYRC=0
YMEGAN%NOCIM=0
YMEGAN%NOMTP=0
YMEGAN%NSABI=0
YMEGAN%NISP=0
YMEGAN%NTRP=0
YMEGAN%NXYLA=0
YMEGAN%NCG5=0
YMEGAN%NSQT=0
YMEGAN%NTOLA=0
YMEGAN%NCG6=0
YMEGAN%NCG4=0
YMEGAN%NISOPRENE=0
YMEGAN%NTRP1=0
YMEGAN%NACET=0
YMEGAN%NMEK=0
YMEGAN%NHCOOH=0
YMEGAN%NCCO_OH=0
YMEGAN%NCCHO=0
YMEGAN%NRCHO=0
YMEGAN%NRCO_OH=0
YMEGAN%NBALD=0
YMEGAN%NETHENE=0
YMEGAN%NALK4=0
YMEGAN%NALK5=0
YMEGAN%NARO1=0
YMEGAN%NARO2=0
YMEGAN%NOLE1=0
YMEGAN%NACID=0
!
YMEGAN%CMECHANISM=' '
YMEGAN%CMECHANISM2=' '
YMEGAN%LCONVERSION=.FALSE.
YMEGAN%NVARS3D=0
YMEGAN%N_SCON_SPC=0
YMEGAN%XDROUGHT=0.
YMEGAN%XDAILYPAR=0.
YMEGAN%XDAILYTEMP=0.
YMEGAN%XMODPREC=0.
IF (LHOOK) CALL DR_HOOK("MODD_MEGAN_n:MEGAN_INIT",1,ZHOOK_HANDLE)
END SUBROUTINE MEGAN_INIT
END MODULE MODD_MEGAN_n
!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!SFX_LIC for details. version 1.
! #########
SUBROUTINE PGD_MEGAN(DTCO, UG, U, USS, MSF, HPROGRAM, OCH_BIOEMIS)
! ##############################################################
!
!!**** *PGD_MEGAN* monitor for averaging and interpolations of physiographic fields
!!
!! PURPOSE
!! -------
!!
!! METHOD
!! ------
!!
!
!! EXTERNAL
!! --------
!!
!! IMPLICIT ARGUMENTS
!! ------------------
!!
!! REFERENCE
!! ---------
!!
!! AUTHOR
!! ------
!!
!! P. Tulet & M. Leriche *LACy & LA*
!!
!! MODIFICATION
!! ------------
!!
!! Original 15/06/2017
!! Modified 06/07/2017 J. Pianezze : adapatation to SurfEx v8.0
!!
!----------------------------------------------------------------------------
!
!* 0. DECLARATION
! -----------
!
USE MODD_DATA_COVER_n, ONLY : DATA_COVER_t
USE MODD_SURF_ATM_GRID_n, ONLY : SURF_ATM_GRID_t
USE MODD_SURF_ATM_n, ONLY : SURF_ATM_t
USE MODD_SSO_n, ONLY : SSO_t
USE MODD_MEGAN_SURF_FIELDS_n,ONLY : MEGAN_SURF_FIELDS_t
!
USE MODD_PGD_GRID, ONLY : NL
USE MODD_PGDWORK, ONLY : CATYPE
USE MODD_SURF_PAR, ONLY : XUNDEF
!
USE MODI_GET_LUOUT
USE MODI_PGD_FIELD
USE MODI_READ_NAM_PGD_MEGAN
USE MODI_UNPACK_SAME_RANK
USE MODI_GET_SURF_SIZE_n
!
USE MODE_POS_SURF
!
!
USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
USE PARKIND1 ,ONLY : JPRB
!
IMPLICIT NONE
!
!* 0.1 Declaration of arguments
! ------------------------
!
TYPE(DATA_COVER_t), INTENT(INOUT) :: DTCO
TYPE(SURF_ATM_GRID_t), INTENT(INOUT) :: UG
TYPE(SURF_ATM_t), INTENT(INOUT) :: U
TYPE(SSO_t), INTENT(INOUT) :: USS
TYPE(MEGAN_SURF_FIELDS_t), INTENT(INOUT) :: MSF
!
CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM ! Type of program
LOGICAL, INTENT(OUT) :: OCH_BIOEMIS ! emission flag
!
!
!* 0.2 Declaration of local variables
! ------------------------------
!
INTEGER :: ILUOUT ! output listing logical unit
INTEGER :: JNBR ! loop counter on dummy fields
INTEGER :: ILU, IL_SEA, IL_LAND, IL
!
!* 0.3 Declaration of namelists
! ------------------------
!
INTEGER :: IMEGAN_NBR
CHARACTER(LEN=20), DIMENSION(1000) :: YMEGAN_NAME
CHARACTER(LEN=3), DIMENSION(1000) :: YMEGAN_AREA
CHARACTER(LEN=3), DIMENSION(1000) :: CMEGAN_ATYPE ! avg type for dummy pgd fields
! ! 'ARI' , 'INV'
CHARACTER(LEN=28), DIMENSION(1000) :: CMEGAN_FILE ! data files
CHARACTER(LEN=6), DIMENSION(1000) :: CMEGAN_FILETYPE ! type of these files
REAL, DIMENSION(:), ALLOCATABLE :: ZMEGAN_FIELD, ZMEGAN_FIELDS
INTEGER, DIMENSION(:), ALLOCATABLE :: IMASK
CHARACTER(LEN=6) :: YMASK
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
!* 1. Initializations of defaults
! ---------------------------
!
IF (LHOOK) CALL DR_HOOK('PGD_MEGAN',0,ZHOOK_HANDLE)
CALL GET_LUOUT(HPROGRAM,ILUOUT)
!
!-------------------------------------------------------------------------------
!
!* 2. Reading of namelist
! -------------------
!
CALL READ_NAM_PGD_MEGAN(HPROGRAM, IMEGAN_NBR, YMEGAN_NAME, YMEGAN_AREA, &
CMEGAN_ATYPE, CMEGAN_FILE, CMEGAN_FILETYPE )
!
MSF%NMEGAN_NBR = IMEGAN_NBR
!
ALLOCATE(MSF%CMEGAN_NAME(MSF%NMEGAN_NBR))
ALLOCATE(MSF%CMEGAN_AREA(MSF%NMEGAN_NBR))
MSF%CMEGAN_NAME(:) = YMEGAN_NAME(1:MSF%NMEGAN_NBR)
MSF%CMEGAN_AREA(:) = YMEGAN_AREA(1:MSF%NMEGAN_NBR)
!
!-------------------------------------------------------------------------------
!
!* 3. Allocation
! ----------
!
ALLOCATE(MSF%XMEGAN_FIELDS(NL,MSF%NMEGAN_NBR))
CALL GET_SURF_SIZE_n(DTCO, U,'LAND', IL_LAND)
CALL GET_SURF_SIZE_n(DTCO, U,'SEA ',IL_SEA)
!
ALLOCATE(ZMEGAN_FIELDS (NL))
!
!-------------------------------------------------------------------------------
OCH_BIOEMIS = MSF%NMEGAN_NBR > 0
!-------------------------------------------------------------------------------
!
!
!* 4. Computations
! ------------
!
DO JNBR=1,MSF%NMEGAN_NBR
CATYPE = CMEGAN_ATYPE(JNBR)
SELECT CASE (MSF%CMEGAN_AREA(JNBR))
CASE ('LAN')
IL = IL_LAND
YMASK='LAND '
CASE ('SEA')
IL = IL_SEA
YMASK='SEA '
CASE ('ALL')
IL = NL
YMASK='FULL '
CASE DEFAULT
CALL ABOR1_SFX('PGD_MEGAN (1): MEGAN AREA NOT SUPPORTED')
END SELECT
ALLOCATE(ZMEGAN_FIELD (IL))
ALLOCATE(IMASK(IL))
!
CALL PGD_FIELD(DTCO, UG, U, USS, &
HPROGRAM,MSF%CMEGAN_NAME(JNBR),MSF%CMEGAN_AREA(JNBR),CMEGAN_FILE(JNBR), &
CMEGAN_FILETYPE(JNBR),XUNDEF,ZMEGAN_FIELD(:) )
CATYPE = 'ARI'
!
!* 4.2 Expends field on all surface points
ILU=0
CALL GET_SURF_MASK_n(DTCO, U, &
YMASK,IL,IMASK,ILU,ILUOUT)
CALL UNPACK_SAME_RANK(IMASK,ZMEGAN_FIELD(:),ZMEGAN_FIELDS(:))
DEALLOCATE(ZMEGAN_FIELD)
DEALLOCATE(IMASK)
!
!* 4.3 Weights field on all surface points
! (zero weight where field is not defined)
SELECT CASE (MSF%CMEGAN_AREA(JNBR))
CASE ('LAN')
MSF%XMEGAN_FIELDS(:,JNBR) = (U%XNATURE(:)+U%XTOWN(:))*ZMEGAN_FIELDS(:)
CASE ('SEA')
MSF%XMEGAN_FIELDS(:,JNBR) = U%XSEA*ZMEGAN_FIELDS(:)
CASE ('ALL')
MSF%XMEGAN_FIELDS(:,JNBR) = ZMEGAN_FIELDS(:)
CASE DEFAULT
CALL ABOR1_SFX('PGD_MEGAN (2): MEGAN AREA NOT SUPPORTED')
END SELECT
END DO
DEALLOCATE(ZMEGAN_FIELDS)
IF (LHOOK) CALL DR_HOOK('PGD_MEGAN',1,ZHOOK_HANDLE)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE PGD_MEGAN
!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!SFX_LIC for details. version 1.
! #########
SUBROUTINE READ_MEGAN_n(MSF, U, HPROGRAM)
! #################################
!
!!**** *READ_MEGAN_n* - routine to READ dummy surface fields
!!
!! PURPOSE
!! -------
!!
!! AUTHOR
!! ------
!! P. Tulet & M. Leriche *LACy & LA*
!!
!! MODIFICATIONS
!! -------------
!! Original 06/2017
!! Modification 07/2017 J. Pianezze adaptation to SurfEx v8
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
! ------------
!
USE MODD_MEGAN_SURF_FIELDS_n, ONLY : MEGAN_SURF_FIELDS_t
USE MODD_SURF_ATM_n, ONLY : SURF_ATM_t
!
USE MODI_READ_SURF
!
USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
USE PARKIND1 ,ONLY : JPRB
!
IMPLICIT NONE
!
!* 0.1 Declarations of arguments
! -------------------------
!
TYPE(MEGAN_SURF_FIELDS_t), INTENT(INOUT) :: MSF
TYPE(SURF_ATM_t), INTENT(INOUT) :: U
!
CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM !
!
!* 0.2 Declarations of local variables
! -------------------------------
!
INTEGER :: JMEGAN ! loop counter
!
CHARACTER(LEN=20 ):: YSTRING20 ! string
CHARACTER(LEN=3 ):: YSTRING03 ! string
!
INTEGER :: IRESP ! IRESP : return-code if a problem appears
CHARACTER(LEN=LEN_HREC) :: YRECFM ! Name of the article to be read
CHARACTER(LEN=100):: YCOMMENT ! Comment string
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
!* 2. Number of dummy fields :
! ----------------------
!
IF (LHOOK) CALL DR_HOOK('READ_MEGAN_N',0,ZHOOK_HANDLE)
!
YRECFM='MEGAN_GR_NBR'
YCOMMENT=' '
!
CALL READ_SURF(HPROGRAM,YRECFM,MSF%NMEGAN_NBR,IRESP,HCOMMENT=YCOMMENT)
!
!-------------------------------------------------------------------------------
!
!* 3. Dummy fields :
! ------------
!
ALLOCATE(MSF%CMEGAN_NAME(MSF%NMEGAN_NBR))
ALLOCATE(MSF%CMEGAN_AREA(MSF%NMEGAN_NBR))
ALLOCATE(MSF%XMEGAN_FIELDS(U%NSIZE_FULL,MSF%NMEGAN_NBR))
MSF%CMEGAN_NAME(:) = ' '
MSF%CMEGAN_AREA(:) = ' '
!
!
DO JMEGAN=1,MSF%NMEGAN_NBR
!
WRITE(YRECFM,FMT='(A8,I3.3,A1)') 'MEGAN_GR',JMEGAN,' '
CALL READ_SURF(HPROGRAM,YRECFM,MSF%XMEGAN_FIELDS(:,JMEGAN),IRESP,HCOMMENT=YCOMMENT)
!
!
YSTRING20=YCOMMENT(21:40)
YSTRING03=YCOMMENT(41:43)
!
MSF%CMEGAN_NAME(JMEGAN) = YSTRING20
MSF%CMEGAN_AREA(JMEGAN) = YSTRING03
WRITE(YRECFM,FMT='(A10,I2.2)') 'MEGAN_NAME',JMEGAN
CALL READ_SURF(HPROGRAM,YRECFM,MSF%CMEGAN_NAME(JMEGAN),IRESP,HCOMMENT=YCOMMENT)
!
END DO
!
IF (LHOOK) CALL DR_HOOK('READ_MEGAN_N',1,ZHOOK_HANDLE)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE READ_MEGAN_n
!SURFEX_LIC Copyright 1994-2014 Meteo-France
!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!SURFEX_LIC for details. version 1.
! #########
SUBROUTINE READ_NAM_PGD_MEGAN(HPROGRAM, KMEGAN_NBR, HMEGAN_NAME, HMEGAN_AREA, &
HMEGAN_ATYPE, HMEGAN_FILE, HMEGAN_FILETYPE )
! ##############################################################
!
!!**** *READ_NAM_PGD_MEGAN* reads namelist NAM_MEGAN_PGD
!!
!! PURPOSE
!! -------
!!
!! METHOD
!! ------
!!
!
!! EXTERNAL
!! --------
!!
!! IMPLICIT ARGUMENTS
!! ------------------
!!
!! REFERENCE
!! ---------
!!
!! AUTHOR
!! ------
!!
!! P. Tulet & M. Leriche *LACy & LA*
!!
!! MODIFICATION
!! ------------
!!
!! Original 06/2017
!!
!----------------------------------------------------------------------------
!
!* 0. DECLARATION
! -----------
!
USE MODI_GET_LUOUT
USE MODI_OPEN_NAMELIST
USE MODI_CLOSE_NAMELIST
!
USE MODE_POS_SURF
!
!
USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
USE PARKIND1 ,ONLY : JPRB
!
IMPLICIT NONE
!
!* 0.1 Declaration of arguments
! ------------------------
!
CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM ! Type of program
INTEGER, INTENT(OUT) :: KMEGAN_NBR
! ! number of megan pgd fields chosen by user
CHARACTER(LEN=20), DIMENSION(1000), INTENT(OUT) :: HMEGAN_NAME
! ! name of the megan pgd fields (for information)
CHARACTER(LEN=3), DIMENSION(1000), INTENT(OUT) :: HMEGAN_AREA
! ! areas where megan pgd fields are defined
! ! 'ALL' : everywhere
! ! 'SEA' : where sea exists
! ! 'LAN' : where land exists
! ! 'WAT' : where inland water exists
! ! 'NAT' : where natural or agricultural areas exist
! ! 'TWN' : where town areas exist
! ! 'STR' : where streets are present
! ! 'BLD' : where buildings are present
CHARACTER(LEN=3), DIMENSION(1000), INTENT(OUT) :: HMEGAN_ATYPE ! avg type for megan pgd fields
! ! 'ARI' , 'INV'
CHARACTER(LEN=28), DIMENSION(1000), INTENT(OUT) :: HMEGAN_FILE ! data files
CHARACTER(LEN=6), DIMENSION(1000), INTENT(OUT) :: HMEGAN_FILETYPE ! type of these files
!
!
!* 0.2 Declaration of local variables
! ------------------------------
!
INTEGER :: ILUOUT ! output listing logical unit
INTEGER :: ILUNAM ! namelist file logical unit
LOGICAL :: GFOUND ! flag when namelist is present
!
!* 0.3 Declaration of namelists
! ------------------------
!
INTEGER :: NMEGAN_NBR
! ! number of megan pgd fields chosen by user
CHARACTER(LEN=20), DIMENSION(1000) :: CMEGAN_NAME
! ! name of the megan pgd fields (for information)
CHARACTER(LEN=3), DIMENSION(1000) :: CMEGAN_AREA
! ! areas where megan pgd fields are defined
! ! 'ALL' : everywhere
! ! 'SEA' : where sea exists
! ! 'LAN' : where land exists
! ! 'WAT' : where inland water exists
! ! 'NAT' : where natural or agricultural areas exist
! ! 'TWN' : where town areas exist
! ! 'STR' : where streets are present
! ! 'BLD' : where buildings are present
CHARACTER(LEN=3), DIMENSION(1000) :: CMEGAN_ATYPE ! avg type for megan pgd fields
! ! 'ARI' , 'INV'
CHARACTER(LEN=28), DIMENSION(1000) :: CMEGAN_FILE ! data files
CHARACTER(LEN=6), DIMENSION(1000) :: CMEGAN_FILETYPE ! type of these files
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
NAMELIST/NAM_MEGAN_PGD/ NMEGAN_NBR, CMEGAN_NAME, CMEGAN_AREA, &
CMEGAN_ATYPE, CMEGAN_FILE, CMEGAN_FILETYPE
!-------------------------------------------------------------------------------
!
!* 1. Initializations of defaults
! ---------------------------
!
IF (LHOOK) CALL DR_HOOK('READ_NAM_PGD_MEGAN',0,ZHOOK_HANDLE)
NMEGAN_NBR = 0
!
CMEGAN_NAME = " "
CMEGAN_FILE = " "
CMEGAN_FILETYPE = " "
CMEGAN_AREA = "ALL"
CMEGAN_ATYPE = "ARI"
!
CALL GET_LUOUT(HPROGRAM,ILUOUT)
!
!-------------------------------------------------------------------------------
!
!* 2. Reading of namelist
! -------------------
!
CALL OPEN_NAMELIST(HPROGRAM,ILUNAM)
!
CALL POSNAM(ILUNAM,'NAM_MEGAN_PGD',GFOUND,ILUOUT)
IF (GFOUND) READ(UNIT=ILUNAM,NML=NAM_MEGAN_PGD)
!
CALL CLOSE_NAMELIST(HPROGRAM,ILUNAM)
!
!-------------------------------------------------------------------------------
!
!* 3. Fills output arguments
! ----------------------
!
KMEGAN_NBR = NMEGAN_NBR
HMEGAN_NAME(:) = CMEGAN_NAME(:)
HMEGAN_AREA(:) = CMEGAN_AREA(:)
HMEGAN_ATYPE(:) = CMEGAN_ATYPE(:)
HMEGAN_FILE(:) = CMEGAN_FILE(:)
HMEGAN_FILETYPE(:) = CMEGAN_FILETYPE(:)
IF (LHOOK) CALL DR_HOOK('READ_NAM_PGD_MEGAN',1,ZHOOK_HANDLE)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE READ_NAM_PGD_MEGAN
!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!SFX_LIC for details. version 1.
! #########
SUBROUTINE WRITESURF_MEGAN_n(HSELECT, MSF, HPROGRAM)
! ##########################################
!
!!**** *WRITESURF_MEGAN_n* - routine to write dummy surface fields
!!
!! PURPOSE
!! -------
!!
!! AUTHOR
!! ------
!! P. Tulet & M. Leriche *LACy & LA*
!!
!! MODIFICATIONS
!! -------------
!! Original 06/2017
!! J. Pianezze 07/2017 adapatation tu SurfEx v8.0
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
! ------------
!
USE MODD_MEGAN_SURF_FIELDS_n, ONLY : MEGAN_SURF_FIELDS_t
!
USE MODI_WRITE_SURF
!
USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
USE PARKIND1 ,ONLY : JPRB
!
IMPLICIT NONE
!
!* 0.1 Declarations of arguments
! -------------------------
!
CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: HSELECT
TYPE(MEGAN_SURF_FIELDS_t), INTENT(INOUT) :: MSF
CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM !
!
!* 0.2 Declarations of local variables
! -------------------------------
!
INTEGER :: JMEGAN ! loop counter
!
CHARACTER(LEN=20) :: YSTRING20 ! string
CHARACTER(LEN=3 ) :: YSTRING03 ! string
!
INTEGER :: IRESP ! IRESP : return-code if a problem appears
CHARACTER(LEN=LEN_HREC) :: YRECFM ! Name of the article to be read
CHARACTER(LEN=100):: YCOMMENT ! Comment string
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
!* 1. Number of megan fields :
! ----------------------
!
IF (LHOOK) CALL DR_HOOK('WRITESURF_MEGAN_N',0,ZHOOK_HANDLE)
!
YRECFM='MEGAN_GR_NBR'
YCOMMENT=' '
!
CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,MSF%NMEGAN_NBR,IRESP,HCOMMENT=YCOMMENT)
!
!-------------------------------------------------------------------------------
!
!* 2. MEGAN fields :
! ------------
!
DO JMEGAN=1,MSF%NMEGAN_NBR
!
WRITE(YRECFM,'(A8,I3.3,A1)') 'MEGAN_GR',JMEGAN,' '
YSTRING20=MSF%CMEGAN_NAME(JMEGAN)
YSTRING03=MSF%CMEGAN_AREA(JMEGAN)
YCOMMENT='X_Y_'//YRECFM//YSTRING20//YSTRING03// &
' '
CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,MSF%XMEGAN_FIELDS(:,JMEGAN),IRESP,HCOMMENT=YCOMMENT)
WRITE(YRECFM,'(A10,I2.2)') 'MEGAN_NAME',JMEGAN
CALL WRITE_SURF(HSELECT, HPROGRAM,YRECFM,MSF%CMEGAN_NAME(JMEGAN),IRESP,HCOMMENT=YCOMMENT)
END DO
IF (LHOOK) CALL DR_HOOK('WRITESURF_MEGAN_N',1,ZHOOK_HANDLE)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE WRITESURF_MEGAN_n
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment