|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 ! ######### 00002 SUBROUTINE BUILD_PRONOSLIST_n(KEMIS_NBR,HEMIS_NAME,TPPRONOS,KCH,KLUOUT,KVERB) 00003 !! ####################################################################### 00004 !! 00005 !!*** *BUILD_PRONOSLIST* 00006 !! 00007 !! PURPOSE 00008 !! ------- 00009 !! 00010 !! 00011 !!** METHOD 00012 !! ------ 00013 !! 00014 !! 00015 !! AUTHOR 00016 !! ------ 00017 !! D. Gazen 00018 !! 00019 !! MODIFICATIONS 00020 !! ------------- 00021 !! Original 01/02/00 00022 !! C. Mari 30/10/00 call to MODD_TYPE_EFUTIL 00023 !! D. Gazen 01/12/03 change emissions handling for surf. externalization 00024 !! P. Tulet 01/05/05 aerosols primary emission 00025 !! 00026 !! EXTERNAL 00027 !! -------- 00028 USE MODI_CH_OPEN_INPUTB 00029 !! 00030 !! IMPLICIT ARGUMENTS 00031 !! ------------------ 00032 USE MODD_TYPE_EFUTIL 00033 USE MODD_SV_n, ONLY: CSV 00034 !------------------------------------------------------------------------------ 00035 ! 00036 !* 0. DECLARATIONS 00037 ! ----------------- 00038 ! 00039 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00040 USE PARKIND1 ,ONLY : JPRB 00041 ! 00042 USE MODI_ABOR1_SFX 00043 ! 00044 IMPLICIT NONE 00045 ! 00046 !* 0.1 declaration of arguments 00047 ! 00048 INTEGER, INTENT(IN) :: KEMIS_NBR ! number of emitted species 00049 CHARACTER(LEN=6), DIMENSION(KEMIS_NBR), INTENT(IN) :: HEMIS_NAME ! name of emitted species 00050 TYPE(PRONOSVAR_T), POINTER :: TPPRONOS 00051 INTEGER, INTENT(IN) :: KCH ! logical unit of input chemistry file 00052 INTEGER, INTENT(IN) :: KLUOUT ! output listing channel 00053 INTEGER, INTENT(IN) :: KVERB ! verbose level 00054 ! 00055 !* 0.2 declaration of local variables 00056 ! 00057 CHARACTER(LEN=256) :: YINPLINE ! input agregation line read from Namelist 00058 INTEGER :: INDX ! 00059 INTEGER :: INBCOEFF ! Numer of agregations coeff for one species 00060 INTEGER :: JI ! loop index 00061 INTEGER :: INDX_PRO ! index of the pronostic variable in CNAMES array 00062 INTEGER :: IERR 00063 CHARACTER(LEN=32) :: YPRO_NAME, YEMIS_NAME ! Name of the pronostic & emission species 00064 LOGICAL :: GFOUND 00065 CHARACTER(LEN=6), DIMENSION(:),POINTER :: CNAMES 00066 TYPE(PRONOSVAR_T), POINTER :: HEAD,CURRENT 00067 INTEGER :: IEQ 00068 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00069 ! 00070 !------------------------------------------------------------------------------ 00071 ! 00072 !* EXECUTABLE STATEMENTS 00073 ! --------------------- 00074 ! 00075 IF (LHOOK) CALL DR_HOOK('BUILD_PRONOSLIST_N',0,ZHOOK_HANDLE) 00076 ! 00077 ! 00078 ! CNAMES points on chemical variables name 00079 CNAMES => CSV 00080 IEQ = SIZE(CSV) 00081 ! 00082 ! Namelist is opened and the agregation eq. are reached 00083 ! 00084 CALL CH_OPEN_INPUTB("AGREGATION", KCH , KLUOUT) 00085 ! 00086 ! Parse each eq. line and build the TPPRONOS list 00087 ! 00088 NULLIFY(HEAD) 00089 NULLIFY(CURRENT) 00090 DO 00091 ! 00092 ! Read a line and convert 'tab' to 'space' characters 00093 ! until the keyword 'END_AGREGATION' is reached 00094 READ(KCH,'(A)',IOSTAT=IERR) YINPLINE 00095 IF (IERR /= 0) EXIT 00096 YINPLINE = TRIM(ADJUSTL(YINPLINE)) 00097 IF (LEN_TRIM(YINPLINE) == 0) CYCLE ! skip blank line 00098 IF (YINPLINE == 'END_AGREGATION') EXIT 00099 CALL TAB2SPACE(YINPLINE) 00100 ! 00101 ! 00102 !Extract pronostic variable name 00103 INDX = INDEX(YINPLINE,' ') 00104 YPRO_NAME = YINPLINE(1:INDX-1) 00105 ! 00106 ! search the variable in CNAMES, STOP if not FOUND 00107 GFOUND = .FALSE. 00108 DO JI=1,IEQ 00109 IF (CNAMES(JI) == YPRO_NAME) THEN 00110 INDX_PRO = JI 00111 GFOUND = .TRUE. 00112 EXIT 00113 END IF 00114 END DO 00115 IF (.NOT. GFOUND) THEN 00116 WRITE(KLUOUT,*) 'BUILD_PRONOSLIST ERROR : ',TRIM(YPRO_NAME),& 00117 ' not found in pronostic variables list !' 00118 CALL ABOR1_SFX('CH_BUILDPRONOSN: VARIABLE NOT FOUND') 00119 END IF 00120 ! 00121 ! If YPRO_NAME variable already encountered : append the new equation (coeffs) 00122 GFOUND = .FALSE. 00123 INBCOEFF = 0 00124 CURRENT=>HEAD 00125 DO WHILE(ASSOCIATED(CURRENT)) 00126 IF (CURRENT%NAMINDEX == INDX_PRO) THEN 00127 INBCOEFF = CURRENT%NBCOEFF 00128 GFOUND = .TRUE. 00129 EXIT 00130 END IF 00131 CURRENT=>CURRENT%NEXT 00132 END DO 00133 IF (.NOT. GFOUND) THEN 00134 ! New pronostic cell is created 00135 ALLOCATE(CURRENT) 00136 CURRENT%NAMINDEX = INDX_PRO 00137 CURRENT%NEXT => HEAD 00138 HEAD => CURRENT 00139 END IF 00140 ! 00141 ! 00142 ! Extract the agregation coeffs 00143 DO 00144 ! get REAL coeff 00145 YINPLINE = ADJUSTL(YINPLINE(INDX:)) 00146 INDX = INDEX(YINPLINE,' ') 00147 IF (INDX == 1) EXIT 00148 INBCOEFF = INBCOEFF+1 00149 IF (INBCOEFF > JPNBCOEFFMAX) THEN 00150 WRITE(KLUOUT,*) 'FATAL ERROR : Number of aggregation coefficients for ',& 00151 TRIM(YPRO_NAME),' exceeds constant JPNBCOEFFMAX = ',JPNBCOEFFMAX 00152 WRITE(KLUOUT,*) '=> You should increase the JPNBCOEFFMAX value in modd_type_efutil.f90' 00153 CALL ABOR1_SFX('CH_BUILDPRONOSN: NUMBER OF AGGREGATION COEFFICIENTS TOO BIG') 00154 END IF 00155 READ(YINPLINE(1:INDX-1),*) CURRENT%XCOEFF(INBCOEFF) 00156 ! 00157 ! get EMIS species name 00158 YINPLINE = ADJUSTL(YINPLINE(INDX:)) 00159 INDX = INDEX(YINPLINE,' ') 00160 YEMIS_NAME = YINPLINE(1:INDX-1) 00161 ! 00162 ! check EMIS species name 00163 GFOUND = .FALSE. 00164 DO JI=1,KEMIS_NBR 00165 IF (HEMIS_NAME(JI) == YEMIS_NAME) THEN 00166 GFOUND = .TRUE. 00167 CURRENT%NEFINDEX(INBCOEFF) = JI 00168 EXIT 00169 END IF 00170 END DO 00171 IF (.NOT. GFOUND) THEN 00172 WRITE(KLUOUT,*) 'ERROR : ',TRIM(YEMIS_NAME),& 00173 ' not found in emission variables list !' 00174 CALL ABOR1_SFX('CH_BUILDPRONOSN: UNKNOWN EMISSION VARIABLE') 00175 END IF 00176 END DO 00177 CURRENT%NBCOEFF = INBCOEFF 00178 END DO 00179 00180 ! 00181 ! Update TPPRONOS pointer with head of list 00182 TPPRONOS => HEAD 00183 ! 00184 IF (KVERB >= 6) THEN 00185 WRITE(KLUOUT,*) 'BUILD_PRONOSLIST: Aggregation results' 00186 CURRENT=>HEAD 00187 DO WHILE(ASSOCIATED(CURRENT)) 00188 WRITE(KLUOUT,*) 'Emission for Atmospheric Chemical Species ',TRIM(CNAMES(CURRENT%NAMINDEX)),' (index ',& 00189 CURRENT%NAMINDEX,' in CSV)' 00190 WRITE(KLUOUT,*) 'is aggregated with the following weights from the Emission Inventory Species:' 00191 DO JI=1,CURRENT%NBCOEFF 00192 WRITE(KLUOUT,*) CURRENT%XCOEFF(JI),HEMIS_NAME(CURRENT%NEFINDEX(JI)) 00193 END DO 00194 CURRENT=>CURRENT%NEXT 00195 END DO 00196 END IF 00197 00198 IF (LHOOK) CALL DR_HOOK('BUILD_PRONOSLIST_N',1,ZHOOK_HANDLE) 00199 CONTAINS 00200 !! 00201 !! ########################### 00202 SUBROUTINE TAB2SPACE(HTEXT) 00203 !! ########################### 00204 !! 00205 !!*** *TAB2SPACE* 00206 !! 00207 !! PURPOSE 00208 !! ------- 00209 !! Convert 'tab' character to 'space' character in the string HTEXT 00210 !! 00211 !!** METHOD 00212 !! ------ 00213 !! 00214 !! AUTHOR 00215 !! ------ 00216 !! D. Gazen 00217 !! 00218 !! MODIFICATIONS 00219 !! ------------- 00220 !! Original 01/02/2000 00221 !! 00222 !! EXTERNAL 00223 !! -------- 00224 !! 00225 !! IMPLICIT ARGUMENTS 00226 !! ------------------ 00227 !------------------------------------------------------------------------------ 00228 ! 00229 !* 0. DECLARATIONS 00230 ! ----------------- 00231 IMPLICIT NONE 00232 ! 00233 !* 0.1 declaration of arguments 00234 ! 00235 CHARACTER(len=*),INTENT(INOUT) :: HTEXT 00236 ! 00237 !* 0.2 declaration of local variables 00238 ! 00239 CHARACTER, PARAMETER :: YPTAB = CHAR(9) ! TAB character is ASCII : 9 00240 INTEGER :: JI 00241 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00242 ! 00243 !------------------------------------------------------------------------------ 00244 ! 00245 !* EXECUTABLE STATEMENTS 00246 ! --------------------- 00247 ! 00248 IF (LHOOK) CALL DR_HOOK('TAB2SPACE',0,ZHOOK_HANDLE) 00249 DO JI=1,LEN_TRIM(HTEXT) 00250 IF (HTEXT(JI:JI) == YPTAB) HTEXT(JI:JI) = ' ' 00251 END DO 00252 IF (LHOOK) CALL DR_HOOK('TAB2SPACE',1,ZHOOK_HANDLE) 00253 END SUBROUTINE TAB2SPACE 00254 00255 END SUBROUTINE BUILD_PRONOSLIST_n
1.8.0
