|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 ! ######################### 00002 SUBROUTINE PGD_ECOCLIMAP2_DATA(HPROGRAM) 00003 ! ######################### 00004 ! 00005 !!**** *PGD_ECOCLIMAP2_DATA* initializes cover-field correspondance arrays 00006 !! 00007 !! PURPOSE 00008 !! ------- 00009 !! 00010 !! METHOD 00011 !! ------ 00012 !! 00013 !! 00014 !! EXTERNAL 00015 !! -------- 00016 !! 00017 !! IMPLICIT ARGUMENTS 00018 !! ------------------ 00019 !! 00020 !! REFERENCE 00021 !! --------- 00022 !! 00023 !! AUTHOR 00024 !! ------ 00025 !! 00026 !! V. Masson Meteo-France 00027 !! 00028 !! MODIFICATION 00029 !! ------------ 00030 !! 00031 !! Original 15/12/97 00032 !! F.solmon 01/06/00 adaptation for patch approach 00033 !---------------------------------------------------------------------------- 00034 ! 00035 !* 0. DECLARATION 00036 ! ----------- 00037 00038 USE MODD_SURF_PAR, ONLY : XUNDEF, NUNDEF 00039 ! 00040 USE MODD_DATA_COVER, ONLY : TDATA_SEED, TDATA_REAP, XDATA_WATSUP, XDATA_IRRIG,& 00041 LDATA_IRRIG, XDATA_VEGTYPE, NYEAR, LCLIM_LAI 00042 00043 ! 00044 00045 USE MODD_DATA_COVER_PAR, ONLY : NVT_IRR, JPCOVER 00046 ! 00047 USE MODI_GET_LUOUT 00048 USE MODI_OPEN_NAMELIST 00049 USE MODI_CLOSE_NAMELIST 00050 USE MODI_OPEN_FILE 00051 USE MODI_CLOSE_FILE 00052 ! 00053 USE MODE_POS_SURF 00054 ! 00055 ! 00056 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00057 USE PARKIND1 ,ONLY : JPRB 00058 ! 00059 USE MODI_ABOR1_SFX 00060 ! 00061 USE MODI_ECOCLIMAP2_LAI 00062 ! 00063 IMPLICIT NONE 00064 ! 00065 !* 0.1 Declaration of arguments 00066 ! ------------------------ 00067 ! 00068 CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM ! Type of program 00069 ! 00070 ! 00071 !* 0.2 Declaration of local variables 00072 ! ------------------------------ 00073 ! 00074 INTEGER :: IGLB ! logical units 00075 INTEGER :: ILUOUT ! output listing logical unit 00076 INTEGER :: IERR ! return codes 00077 INTEGER :: ILUNAM ! namelist file logical unit 00078 LOGICAL :: GFOUND ! true if namelist is found 00079 ! 00080 INTEGER :: JCOVER,JDEC,JVEGTYPE ! loop counters on covers and decades 00081 ! 00082 INTEGER, DIMENSION(:), ALLOCATABLE :: IVALUE ! value of a record of data points 00083 00084 ! 00085 !* 0.3 Declaration of namelists 00086 ! ------------------------ 00087 ! 00088 CHARACTER(LEN=28) :: YIRRIG ! file name for irrigation 00089 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00090 ! 00091 NAMELIST/NAM_ECOCLIMAP2/ YIRRIG, LCLIM_LAI 00092 !------------------------------------------------------------------------------- 00093 00094 !------------------------------------------------------------------------------- 00095 !------------------------------------------------------------------------------- 00096 !------------------------------------------------------------------------------- 00097 ! 00098 !* 1. Read namelist 00099 ! ------------------------------------- 00100 ! 00101 !* Initializations 00102 ! 00103 IF (LHOOK) CALL DR_HOOK('PGD_ECOCLIMAP2_DATA',0,ZHOOK_HANDLE) 00104 YIRRIG = ' ' 00105 LCLIM_LAI = .TRUE. 00106 NYEAR = NUNDEF 00107 ! 00108 !* Reading 00109 ! 00110 CALL GET_LUOUT(HPROGRAM,ILUOUT) 00111 CALL OPEN_NAMELIST(HPROGRAM,ILUNAM) 00112 ! 00113 CALL POSNAM(ILUNAM,'NAM_ECOCLIMAP2',GFOUND,ILUOUT) 00114 IF (GFOUND) READ(UNIT=ILUNAM,NML=NAM_ECOCLIMAP2) 00115 ! 00116 CALL CLOSE_NAMELIST(HPROGRAM,ILUNAM) 00117 ! 00118 !------------------------------------------------------------------------------- 00119 ! 00120 !* 2. Verifications 00121 ! ---------------- 00122 ! 00123 LDATA_IRRIG=(LEN_TRIM(YIRRIG)>0) 00124 ! 00125 !------------------------------------------------------------------------------- 00126 ! 00127 ! 00128 !* 3. second version of ecoclimap (europe) 00129 ! ----------------------------------- 00130 ! 00131 ! 00132 !* 3.1. read the irrigation data 00133 ! ---------------------- 00134 ! 00135 IERR=0 00136 00137 IF (LEN_TRIM(YIRRIG)>0) THEN 00138 ALLOCATE(IVALUE(7)) 00139 00140 CALL OPEN_FILE(HPROGRAM,IGLB,YIRRIG,'FORMATTED',HACTION='READ') 00141 00142 DO JCOVER=301,JPCOVER 00143 READ(IGLB,FMT='(7I4)') IVALUE 00144 IF (XDATA_VEGTYPE(JCOVER,NVT_IRR).NE.0) THEN 00145 TDATA_SEED(JCOVER,NVT_IRR )%TDATE%MONTH = IVALUE(2) 00146 TDATA_SEED(JCOVER,NVT_IRR )%TDATE%DAY = IVALUE(3) 00147 TDATA_REAP(JCOVER,NVT_IRR )%TDATE%MONTH = IVALUE(4) 00148 TDATA_REAP(JCOVER,NVT_IRR )%TDATE%DAY = IVALUE(5) 00149 XDATA_WATSUP(JCOVER,NVT_IRR) = IVALUE(6) 00150 XDATA_IRRIG (JCOVER,NVT_IRR) = IVALUE(7) 00151 ENDIF 00152 ! 00153 IF (XDATA_VEGTYPE(JCOVER,NVT_IRR).NE.0 .AND. & 00154 (IVALUE(2).EQ.0 .OR. IVALUE(3).EQ.0 .OR. IVALUE(4).EQ.0 .OR. & 00155 IVALUE(5).EQ.0 .OR. IVALUE(6).EQ.0 .OR. IVALUE(7).EQ.0)) THEN 00156 WRITE(ILUOUT,*)'**************************************************' 00157 WRITE(ILUOUT,*)'* error, missing data in ',YIRRIG,' for *' 00158 WRITE(ILUOUT,*)'* the class ',JCOVER,'. *' 00159 WRITE(ILUOUT,*)'**************************************************' 00160 IERR=1 00161 ENDIF 00162 IF (XDATA_VEGTYPE(JCOVER,NVT_IRR).EQ.0 .AND. & 00163 (IVALUE(2).NE.0 .OR. IVALUE(3).NE.0 .OR. IVALUE(4).NE.0 .OR. & 00164 IVALUE(5).NE.0 .OR. IVALUE(6).NE.0 .OR. IVALUE(7).NE.0)) THEN 00165 WRITE(ILUOUT,*)'**************************************************' 00166 WRITE(ILUOUT,*)'* error, too many data in ',YIRRIG,' for *' 00167 WRITE(ILUOUT,*)'* the class ',JCOVER,'. *' 00168 WRITE(ILUOUT,*)'**************************************************' 00169 IERR=1 00170 ENDIF 00171 ENDDO 00172 00173 CALL CLOSE_FILE(HPROGRAM,IGLB) 00174 00175 IF (IERR.EQ.1) CALL ABOR1_SFX('PGD_ECOCLIMAP2_DATA (3)') 00176 00177 DEALLOCATE(IVALUE) 00178 END IF 00179 ! 00180 !------------------------------------------------------------------------------- 00181 ! 00182 ! 4. Computes LAI evolution for the chosen year 00183 ! ------------------------------------------ 00184 ! 00185 CALL ECOCLIMAP2_LAI 00186 IF (LHOOK) CALL DR_HOOK('PGD_ECOCLIMAP2_DATA',1,ZHOOK_HANDLE) 00187 ! 00188 !------------------------------------------------------------------------------- 00189 ! 00190 END SUBROUTINE PGD_ECOCLIMAP2_DATA
1.8.0
