write_data.F90

Go to the documentation of this file.

!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 write_data(HPROGRAM)
!     #########################
!
!!**** *WRITE_DATA* initializes cover-field correspondance arrays
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    15/12/97
!!    F.solmon    01/06/00 adaptation for patch approach
!!    R. Alkama    05/2012 : add new vegtypes (from 12 to 19)
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------

USE modd_surf_par,       ONLY : xundef
!
USE modd_data_cover,     ONLY : xdata_town, xdata_nature, xdata_sea, xdata_water, &
                                  xdata_lai, xdata_vegtype, xdata_h_tree,           &
                                  xdata_ground_depth, xdata_root_depth,             &
                                  tdata_seed, tdata_reap, xdata_watsup, xdata_irrig,&
                                  xdata_lai_all_years  
USE modd_data_cover_par, ONLY : cnames, nvegtype
!

USE modd_data_cover_par, ONLY : nvegtype, jpcover, nvt_irr
!
!
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
!
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
!
INTEGER               :: JCOVER,JDEC,JK ! loop counters on covers, decades and vegtypes
INTEGER :: JBEG
!
!*    0.3    Declaration of namelists
!            ------------------------
!
 CHARACTER(LEN=8), DIMENSION(NVEGTYPE) :: CNVT
 CHARACTER(LEN=2) :: CF
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('WRITE_DATA',0,zhook_handle)
IF (nvt_irr/=0) THEN
  jbeg = 301
  cnvt(1) =  "NVT_NO  "      ! no vegetation (smooth)
  cnvt(2) =  "NVT_ROCK"      ! no vegetation (rocks)
  cnvt(3) =  "NVT_SNOW"      ! permanent snow and ice
  cnvt(4) =  "NVT_TEBD"      ! temperate broadleaf deciduous trees
  cnvt(5) =  "NVT_BONE"      ! boreal needleleaf evergreen trees 
  cnvt(6) =  "NVT_TRBE"      ! tropical broadleaf evergreen trees
  cnvt(7) =  "NVT_C3  "      ! C3 cultures types
  cnvt(8) =  "NVT_C4  "      ! C4 cultures types
  cnvt(9) =  "NVT_IRR "      ! irrigated crops
  cnvt(10)=  "NVT_GRAS"      ! temperate grassland C3
  cnvt(11)=  "NVT_TROG"      ! tropical  grassland C4
  cnvt(12)=  "NVT_PARK"      ! peat bogs, parks and gardens (irrigated grass)
  cnvt(13)=  "NVT_TRBD"      ! tropical  broadleaf  deciduous trees
  cnvt(14)=  "NVT_TEBE"      ! temperate broadleaf  evergreen trees
  cnvt(15)=  "NVT_TENE"      ! temperate needleleaf evergreen trees
  cnvt(16)=  "NVT_BOBD"      ! boreal    broadleaf  deciduous trees
  cnvt(17)=  "NVT_BOND"      ! boreal    needleleaf deciduous trees
  cnvt(18)=  "NVT_BOGR"      ! boreal grassland C3
  cnvt(19)=  "NVT_SHRB"      ! broadleaf shrub
ELSE
  jbeg = 1
  cnvt(1) =  "NVT_NO  "      ! no vegetation (smooth)
  cnvt(2) =  "NVT_ROCK"      ! no vegetation (rocks)
  cnvt(3) =  "NVT_SNOW"      ! permanent snow and ice
  cnvt(4) =  "NVT_BOBD"      ! boreal    broadleaf  deciduous trees
  cnvt(5) =  "NVT_TEBD"      ! temperate broadleaf deciduous trees
  cnvt(6) =  "NVT_TRBD"      ! tropical  broadleaf  deciduous trees
  cnvt(7) =  "NVT_TEBE"      ! temperate broadleaf  evergreen trees
  cnvt(8) =  "NVT_TRBE"      ! tropical broadleaf evergreen trees
  cnvt(9) =  "NVT_BONE"      ! boreal needleleaf evergreen trees 
  cnvt(10)=  "NVT_TENE"      ! temperate needleleaf evergreen trees
  cnvt(11)=  "NVT_BOND"      ! boreal    needleleaf deciduous trees
  cnvt(12)=  "NVT_GRAS"      ! temperate grassland C3
  cnvt(13)=  "NVT_TROG"      ! tropical  grassland C4
  cnvt(14)=  "NVT_BOGR"      ! boreal grassland C3
  cnvt(15)=  "NVT_SHRB"      ! broadleaf shrub
  cnvt(16)=  "NVT_C3W "      ! winter C3 cultures types
  cnvt(17)=  "NVT_C3E "      ! summer C3 cultures types
  cnvt(18)=  "NVT_C4  "      ! C4 cultures types
  cnvt(19)=  "NVT_FLTR"      ! flooded trees
  cnvt(20)=  "NVT_FLGR"      ! flooded grassland
ENDIF
!
DO jcover=jbeg,jpcover
WRITE(*,fmt='(A80)') '!-------------------------------------------------------------------------------'
WRITE(*,fmt='(A16,I3.3)') 'SUBROUTINE COVER',jcover
WRITE(*,fmt='(A1)') '!'
WRITE(*,fmt='(A10,I3.3)') '!*   cover',jcover
WRITE(*,fmt='(A5,A60)')   '!    ',cnames(jcover,1)
WRITE(*,fmt='(A1)') '!'
WRITE(*,fmt='(A7,I3)') 'ICOVER=',jcover
WRITE(*,fmt='(A1)') '!'
WRITE(*,fmt='(A21,F4.2)') 'XDATA_TOWN  (ICOVER)=',xdata_town(jcover)
WRITE(*,fmt='(A21,F4.2)') 'XDATA_NATURE(ICOVER)=',xdata_nature(jcover)
WRITE(*,fmt='(A21,F4.2)') 'XDATA_WATER (ICOVER)=',xdata_water(jcover)
WRITE(*,fmt='(A21,F4.2)') 'XDATA_SEA   (ICOVER)=',xdata_sea(jcover)
WRITE(*,fmt='(A1)') '!'
DO jk=1,19
  IF (xdata_vegtype(jcover,jk)==0.) cycle
  IF (all(xdata_lai_all_years(jcover,:,jk)==0.)) THEN
    WRITE(*,fmt='(A29,A8,A5)') &
           'XDATA_LAI_ALL_YEARS(ICOVER,:,',cnvt(jk),')= 0.'  
    cycle
  END IF
  WRITE(*,fmt='(A29,A8,A7)') &
           'XDATA_LAI_ALL_YEARS(ICOVER,:,',cnvt(jk),')= (/ &'  
  DO jdec=1,18
    cf=', '
    IF (jdec==18) cf='  '
    WRITE(*,fmt='(A7,12(F4.1,A2),A1)') '       ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+1,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+2,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+3,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+4,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+5,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+6,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+7,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+8,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+9,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+10,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+11,jk),0.1),', ', &
         max(xdata_lai_all_years(jcover,(jdec-1)*12+12,jk),0.1),cf,'&'   
  END DO
  WRITE(*,fmt='(A7)') '     /)'
END DO
WRITE(*,fmt='(A1)') '!'
DO jk=1,19
  IF (xdata_vegtype(jcover,jk)==0.) cycle
  WRITE(*,fmt='(A21,A8,A3,F4.2)') &
           'XDATA_VEGTYPE(ICOVER,',cnvt(jk),')= ',xdata_vegtype(jcover,jk)  
END DO
WRITE(*,fmt='(A1)') '!'
DO jk=4,6
  IF (xdata_vegtype(jcover,jk)==0.) cycle
  WRITE(*,fmt='(A20,A8,A3,F4.1)') &
           'XDATA_H_TREE(ICOVER,',cnvt(jk),')= ',xdata_h_tree(jcover,jk)  
END DO
WRITE(*,fmt='(A1)') '!'
DO jk=1,19
  IF (xdata_vegtype(jcover,jk)==0.) cycle
  WRITE(*,fmt='(A24,A8,A3,F4.1)') &
           'XDATA_ROOT_DEPTH(ICOVER,',cnvt(jk),')= ',xdata_root_depth(jcover,jk)  
END DO
WRITE(*,fmt='(A1)') '!'
DO jk=1,19
  IF (xdata_vegtype(jcover,jk)==0.) cycle
  WRITE(*,fmt='(A26,A8,A3,F4.1)') &
           'XDATA_GROUND_DEPTH(ICOVER,',cnvt(jk),')= ',xdata_ground_depth(jcover,jk)  
END DO
WRITE(*,fmt='(A1)') '!'
IF (xdata_vegtype(jcover,9)/=0.) THEN
  WRITE(*,fmt='(A18,A8,A15,I2.2)') &
          'TDATA_SEED(ICOVER,',cnvt(9),')%TDATE%MONTH= ',tdata_seed(jcover,9)%TDATE%MONTH  
  WRITE(*,fmt='(A18,A8,A15,I2.2)') &
          'TDATA_SEED(ICOVER,',cnvt(9),')%TDATE%DAY  = ',tdata_seed(jcover,9)%TDATE%DAY  
  WRITE(*,fmt='(A18,A8,A15,I2.2)') &
          'TDATA_REAP(ICOVER,',cnvt(9),')%TDATE%MONTH= ',tdata_reap(jcover,9)%TDATE%MONTH  
  WRITE(*,fmt='(A18,A8,A15,I2.2)') &
          'TDATA_REAP(ICOVER,',cnvt(9),')%TDATE%DAY  = ',tdata_reap(jcover,9)%TDATE%DAY  
  WRITE(*,fmt='(A20,A8,A3,F4.1)') &
           'XDATA_WATSUP(ICOVER,',cnvt(9),')= ',xdata_watsup(jcover,9)  
  WRITE(*,fmt='(A20,A8,A3,F4.1)') &
           'XDATA_IRRIG (ICOVER,',cnvt(9),')= ',xdata_irrig(jcover,9)  
END IF
WRITE(*,fmt='(A20,I3.3)') 'END SUBROUTINE COVER',jcover
END DO
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
DO jcover=jbeg,jpcover
  WRITE(*,fmt='(A10,I3.3)') 'CALL COVER',jcover
END DO
IF (lhook) CALL dr_hook('WRITE_DATA',1,zhook_handle)
!-------------------------------------------------------------------------------
!
END SUBROUTINE write_data