|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 MODULE MODE_WRITE_SURF_FA 00002 ! 00003 INTERFACE WRITE_SURF0_FA 00004 MODULE PROCEDURE WRITE_SURFX0_FA 00005 MODULE PROCEDURE WRITE_SURFN0_FA 00006 MODULE PROCEDURE WRITE_SURFL0_FA 00007 MODULE PROCEDURE WRITE_SURFC0_FA 00008 END INTERFACE 00009 INTERFACE WRITE_SURFN_FA 00010 MODULE PROCEDURE WRITE_SURFX1_FA 00011 MODULE PROCEDURE WRITE_SURFN1_FA 00012 MODULE PROCEDURE WRITE_SURFL1_FA 00013 MODULE PROCEDURE WRITE_SURFX2_FA 00014 END INTERFACE 00015 INTERFACE WRITE_SURFT_FA 00016 MODULE PROCEDURE WRITE_SURFT0_FA 00017 MODULE PROCEDURE WRITE_SURFT2_FA 00018 END INTERFACE 00019 ! 00020 CONTAINS 00021 ! 00022 ! ############################################################# 00023 SUBROUTINE WRITE_SURFX0_FA(HREC,PFIELD,KRESP,HCOMMENT) 00024 ! ############################################################# 00025 ! 00026 !!**** * - routine to write a real scalar 00027 ! 00028 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, LFANOCOMPACT 00029 ! 00030 USE MODE_FASURFEX 00031 ! 00032 USE MODI_IO_BUFF_n 00033 USE MODI_ERROR_WRITE_SURF_FA 00034 ! 00035 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00036 USE PARKIND1 ,ONLY : JPRB 00037 ! 00038 IMPLICIT NONE 00039 ! 00040 !* 0.1 Declarations of arguments 00041 ! 00042 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00043 REAL, INTENT(IN) :: PFIELD ! the real scalar to be read 00044 INTEGER, INTENT(OUT):: KRESP ! KRESP : return-code if a problem appears 00045 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00046 ! 00047 !* 0.2 Declarations of local variables 00048 ! 00049 LOGICAL :: GKNOWN 00050 CHARACTER(LEN=18):: YNAME ! Field Name 00051 INTEGER :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00052 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00053 ! 00054 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:ERROR_WRITE_SURF_FA:WRITE_SURFX0_FA',0,ZHOOK_HANDLE) 00055 ! 00056 KRESP=0 00057 ! 00058 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00059 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX0_FA',1,ZHOOK_HANDLE) 00060 IF (GKNOWN) RETURN 00061 ! 00062 IF(LFANOCOMPACT)THEN 00063 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00064 ! -- Pour ecrire sans compactage 00065 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00066 ENDIF 00067 ! 00068 YNAME=TRIM(CMASK)//TRIM(HREC) 00069 CALL FAECR_R(KRESP,NUNIT_FA,YNAME,PFIELD) 00070 IF (KRESP/=0) THEN 00071 CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00072 ENDIF 00073 ! 00074 IF(LFANOCOMPACT)THEN 00075 ! On remet la valeur par defaut 00076 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00077 ENDIF 00078 ! 00079 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX0_FA',1,ZHOOK_HANDLE) 00080 ! 00081 END SUBROUTINE WRITE_SURFX0_FA 00082 ! 00083 ! ############################################################# 00084 SUBROUTINE WRITE_SURFN0_FA(HREC,KFIELD,KRESP,HCOMMENT) 00085 ! ############################################################# 00086 ! 00087 !!**** * - routine to write an integer 00088 ! 00089 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, NMASK, CMASK, LFANOCOMPACT 00090 ! 00091 USE MODE_FASURFEX 00092 ! 00093 USE MODI_IO_BUFF_n 00094 USE MODI_ERROR_WRITE_SURF_FA 00095 ! 00096 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00097 USE PARKIND1 ,ONLY : JPRB 00098 ! 00099 IMPLICIT NONE 00100 ! 00101 !* 0.1 Declarations of arguments 00102 ! 00103 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00104 INTEGER, INTENT(IN) :: KFIELD ! the integer to be read 00105 INTEGER, INTENT(OUT):: KRESP ! KRESP : return-code if a problem appears 00106 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00107 ! 00108 !* 0.2 Declarations of local variables 00109 ! 00110 CHARACTER(LEN=18):: YNAME ! Field Name 00111 LOGICAL :: GKNOWN 00112 INTEGER :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00113 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00114 ! 00115 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',0,ZHOOK_HANDLE) 00116 ! 00117 KRESP=0 00118 ! 00119 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00120 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',1,ZHOOK_HANDLE) 00121 IF (GKNOWN) RETURN 00122 ! 00123 IF(LFANOCOMPACT)THEN 00124 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00125 ! -- Pour ecrire sans compactage 00126 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00127 ENDIF 00128 ! 00129 YNAME=TRIM(CMASK)//TRIM(HREC) 00130 CALL FAECR_I(KRESP,NUNIT_FA,YNAME,KFIELD) 00131 IF (KRESP/=0) THEN 00132 CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00133 ENDIF 00134 ! 00135 IF(LFANOCOMPACT)THEN 00136 ! On remet la valeur par defaut 00137 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00138 ENDIF 00139 ! 00140 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',1,ZHOOK_HANDLE) 00141 ! 00142 END SUBROUTINE WRITE_SURFN0_FA 00143 ! 00144 ! ############################################################# 00145 SUBROUTINE WRITE_SURFL0_FA(HREC,OFIELD,KRESP,HCOMMENT) 00146 ! ############################################################# 00147 ! 00148 !!**** * - routine to write a logical 00149 ! 00150 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, LFANOCOMPACT 00151 ! 00152 USE MODE_FASURFEX 00153 ! 00154 USE MODI_IO_BUFF_n 00155 USE MODI_ERROR_WRITE_SURF_FA 00156 ! 00157 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00158 USE PARKIND1 ,ONLY : JPRB 00159 ! 00160 IMPLICIT NONE 00161 ! 00162 !* 0.1 Declarations of arguments 00163 ! 00164 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00165 LOGICAL, INTENT(IN) :: OFIELD ! array containing the data field 00166 INTEGER, INTENT(OUT):: KRESP ! KRESP : return-code if a problem appears 00167 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00168 ! 00169 !* 0.2 Declarations of local variables 00170 ! 00171 CHARACTER(LEN=18):: YNAME ! Field Name 00172 LOGICAL :: GKNOWN 00173 INTEGER :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00174 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00175 ! 00176 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',0,ZHOOK_HANDLE) 00177 ! 00178 KRESP=0 00179 ! 00180 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00181 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',1,ZHOOK_HANDLE) 00182 IF (GKNOWN) RETURN 00183 ! 00184 IF(LFANOCOMPACT)THEN 00185 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00186 ! -- Pour ecrire sans compactage 00187 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00188 ENDIF 00189 ! 00190 YNAME=TRIM(CMASK)//TRIM(HREC) 00191 CALL FAECR_L(KRESP,NUNIT_FA,YNAME,OFIELD) 00192 IF (KRESP/=0) THEN 00193 CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00194 ENDIF 00195 ! 00196 IF(LFANOCOMPACT)THEN 00197 ! On remet la valeur par defaut 00198 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00199 ENDIF 00200 ! 00201 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',1,ZHOOK_HANDLE) 00202 ! 00203 END SUBROUTINE WRITE_SURFL0_FA 00204 ! 00205 ! ############################################################# 00206 SUBROUTINE WRITE_SURFC0_FA(HREC,HFIELD,KRESP,HCOMMENT) 00207 ! ############################################################# 00208 ! 00209 !!**** * - routine to write a character 00210 ! 00211 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, LFANOCOMPACT 00212 ! 00213 USE MODE_FASURFEX 00214 ! 00215 USE MODI_IO_BUFF_n 00216 USE MODI_ERROR_WRITE_SURF_FA 00217 ! 00218 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00219 USE PARKIND1 ,ONLY : JPRB 00220 ! 00221 IMPLICIT NONE 00222 ! 00223 !* 0.1 Declarations of arguments 00224 ! 00225 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00226 CHARACTER(LEN=40), INTENT(IN) :: HFIELD ! the integer to be read 00227 INTEGER, INTENT(OUT) :: KRESP ! KRESP : return-code if a problem appears 00228 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00229 ! 00230 !* 0.2 Declarations of local variables 00231 ! 00232 CHARACTER,DIMENSION(40) :: YFIELD 00233 CHARACTER(LEN=18) :: YNAME ! Field Name 00234 LOGICAL :: GKNOWN 00235 INTEGER :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00236 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00237 ! 00238 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',0,ZHOOK_HANDLE) 00239 ! 00240 KRESP=0 00241 ! 00242 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00243 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',1,ZHOOK_HANDLE) 00244 IF (GKNOWN) RETURN 00245 ! 00246 IF(LFANOCOMPACT)THEN 00247 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00248 ! -- Pour ecrire sans compactage 00249 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00250 ENDIF 00251 ! 00252 READ(HFIELD,'(40A1)') YFIELD 00253 YNAME=TRIM(CMASK)//TRIM(HREC) 00254 CALL FAECR_C(KRESP,NUNIT_FA,YNAME,40,YFIELD) 00255 IF (KRESP/=0) THEN 00256 CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00257 ENDIF 00258 ! 00259 IF(LFANOCOMPACT)THEN 00260 ! On remet la valeur par defaut 00261 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00262 ENDIF 00263 ! 00264 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',1,ZHOOK_HANDLE) 00265 ! 00266 END SUBROUTINE WRITE_SURFC0_FA 00267 ! 00268 ! ############################################################# 00269 SUBROUTINE WRITE_SURFX1_FA(HREC,KL,PFIELD,KRESP,HCOMMENT,HDIR) 00270 ! ############################################################# 00271 ! 00272 !!**** * - routine to fill a write 1D array for the externalised surface 00273 ! 00274 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE, WLOG_MPI 00275 ! 00276 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, NMASK, NFULL, CMASK, & 00277 LFANOCOMPACT 00278 USE MODD_SURF_PAR, ONLY : XUNDEF 00279 ! 00280 USE MODI_IO_BUFF_n 00281 USE MODI_ERROR_WRITE_SURF_FA 00282 USE MODI_GATHER_AND_WRITE_MPI 00283 ! 00284 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00285 USE PARKIND1 ,ONLY : JPRB 00286 ! 00287 IMPLICIT NONE 00288 ! 00289 #ifndef NOMPI 00290 INCLUDE "mpif.h" 00291 #endif 00292 ! 00293 !* 0.1 Declarations of arguments 00294 ! 00295 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00296 INTEGER, INTENT(IN) :: KL ! number of points 00297 REAL, DIMENSION(KL), INTENT(IN) :: PFIELD ! array containing the data field 00298 INTEGER, INTENT(OUT):: KRESP ! KRESP : return-code if a problem appears 00299 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00300 CHARACTER(LEN=1), INTENT(IN) :: HDIR ! type of field : 00301 ! 'H' : field with 00302 ! horizontal spatial dim. 00303 ! '-' : no horizontal dim. 00304 !* 0.2 Declarations of local variables 00305 ! 00306 LOGICAL :: GKNOWN 00307 INTEGER :: I,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00308 REAL :: ZMEAN, ZCOUNT 00309 DOUBLE PRECISION :: XTIME0 00310 REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD))) :: ZWORK ! work array read in the file 00311 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00312 ! 00313 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',0,ZHOOK_HANDLE) 00314 ! 00315 KRESP=0 00316 ! 00317 !$OMP SINGLE 00318 ! 00319 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00320 ! 00321 !$OMP END SINGLE COPYPRIVATE(GKNOWN) 00322 ! 00323 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',1,ZHOOK_HANDLE) 00324 IF (GKNOWN) RETURN 00325 ! 00326 IF(HDIR=='H')THEN 00327 CALL GATHER_AND_WRITE_MPI(PFIELD,ZWORK,NMASK) 00328 ELSE !no horizontal dim. case (not masked) 00329 ZWORK(1:KL)=PFIELD(1:KL) 00330 ZWORK(KL+1:NFULL)=SUM(PFIELD(1:KL))/REAL(KL) 00331 ENDIF 00332 ! 00333 IF (NRANK==NPIO) THEN 00334 ! 00335 #ifndef NOMPI 00336 XTIME0 = MPI_WTIME() 00337 #endif 00338 ! 00339 !$OMP SINGLE 00340 ! 00341 IF(LFANOCOMPACT)THEN 00342 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00343 ! -- Pour ecrire sans compactage 00344 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00345 CALL FAIENC(KRESP,NUNIT_FA,'S1D_',0,HREC,ZWORK,.FALSE.) 00346 IF (KRESP/=0) CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00347 ! On remet la valeur par defaut 00348 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00349 ELSE 00350 ZMEAN =0.0 00351 ZCOUNT=0.0 00352 DO I=1,NFULL 00353 IF(ZWORK(I)/=XUNDEF)THEN 00354 ZMEAN =ZMEAN+ZWORK(I) 00355 ZCOUNT=ZCOUNT+1.0 00356 ENDIF 00357 ENDDO 00358 IF (ZCOUNT.GT.0.0) ZMEAN=ZMEAN/ZCOUNT 00359 WHERE(ZWORK(:)==XUNDEF)ZWORK(:)=ZMEAN 00360 CALL FAIENC(KRESP,NUNIT_FA,'S1D_',0,HREC,ZWORK,.FALSE.) 00361 IF (KRESP/=0) CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00362 ENDIF 00363 ! 00364 !$OMP END SINGLE COPYPRIVATE(KRESP) 00365 ! 00366 #ifndef NOMPI 00367 XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0) 00368 #endif 00369 ! 00370 ENDIF 00371 ! 00372 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',1,ZHOOK_HANDLE) 00373 ! 00374 END SUBROUTINE WRITE_SURFX1_FA 00375 ! 00376 ! ############################################################# 00377 SUBROUTINE WRITE_SURFX2_FA(HREC,KL1,KL2,PFIELD,KRESP,HCOMMENT,HDIR) 00378 ! ############################################################# 00379 ! 00380 !!**** * - routine to fill a write 2D array for the externalised surface 00381 ! 00382 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE 00383 ! 00384 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, NMASK, NFULL, & 00385 CMASK, LFANOCOMPACT 00386 USE MODD_SURF_PAR, ONLY : XUNDEF 00387 ! 00388 USE MODI_IO_BUFF_n 00389 USE MODI_ERROR_WRITE_SURF_FA 00390 USE MODI_GATHER_AND_WRITE_MPI 00391 ! 00392 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00393 USE PARKIND1 ,ONLY : JPRB 00394 ! 00395 IMPLICIT NONE 00396 ! 00397 #ifndef NOMPI 00398 INCLUDE "mpif.h" 00399 #endif 00400 ! 00401 !* 0.1 Declarations of arguments 00402 ! 00403 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00404 INTEGER, INTENT(IN) :: KL1 ! number of points 00405 INTEGER, INTENT(IN) :: KL2 ! 2nd dimension 00406 REAL, DIMENSION(KL1,KL2), INTENT(IN) :: PFIELD ! array containing the data field 00407 INTEGER, INTENT(OUT):: KRESP ! KRESP : return-code if a problem appears 00408 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00409 CHARACTER(LEN=1), INTENT(IN) :: HDIR ! type of field : 00410 ! 'H' : field with 00411 ! horizontal spatial dim. 00412 ! '-' : no horizontal dim. 00413 !* 0.2 Declarations of local variables 00414 ! 00415 CHARACTER(LEN=4) :: YSUFFIX 00416 CHARACTER(LEN=2) :: YPATCH 00417 LOGICAL :: GKNOWN 00418 INTEGER :: I, JL ! loop counter 00419 INTEGER :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00420 DOUBLE PRECISION :: XTIME0 00421 REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD,1)),SIZE(PFIELD,2)) :: ZWORK ! work array read in the file 00422 REAL, DIMENSION(SIZE(PFIELD,2)) :: ZMEAN, ZCOUNT 00423 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00424 ! 00425 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',0,ZHOOK_HANDLE) 00426 ! 00427 KRESP=0 00428 ! 00429 !$OMP SINGLE 00430 ! 00431 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00432 ! 00433 !$OMP END SINGLE COPYPRIVATE(GKNOWN) 00434 ! 00435 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',1,ZHOOK_HANDLE) 00436 IF (GKNOWN) RETURN 00437 ! 00438 CALL GATHER_AND_WRITE_MPI(PFIELD,ZWORK,NMASK) 00439 ! 00440 IF (NRANK==NPIO) THEN 00441 ! 00442 #ifndef NOMPI 00443 XTIME0 = MPI_WTIME() 00444 #endif 00445 ! 00446 !$OMP SINGLE 00447 ! 00448 IF(LFANOCOMPACT)THEN 00449 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00450 ! -- Pour ecrire sans compactage 00451 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00452 DO JL=1,SIZE(ZWORK,2) 00453 WRITE(YPATCH,'(I2.2)')JL 00454 YSUFFIX='S'//YPATCH//'_' 00455 CALL FAIENC(KRESP,NUNIT_FA,YSUFFIX,0,HREC,ZWORK(:,JL),.FALSE.) 00456 IF (KRESP/=0) CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00457 END DO 00458 ! On remet la valeur par defaut 00459 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00460 ELSE 00461 ZMEAN (:)=0.0 00462 ZCOUNT(:)=0.0 00463 DO I=1,NFULL 00464 DO JL=1,SIZE(ZWORK,2) 00465 IF(ZWORK(I,JL)/=XUNDEF) THEN 00466 ZMEAN (JL)=ZMEAN(JL)+ZWORK(I,JL) 00467 ZCOUNT(JL)=ZCOUNT(JL)+1.0 00468 ENDIF 00469 ENDDO 00470 ENDDO 00471 WHERE(ZCOUNT(:)>0.0)ZMEAN(:)=ZMEAN(:)/ZCOUNT(:) 00472 DO JL=1,SIZE(ZWORK,2) 00473 WHERE(ZWORK(:,JL)==XUNDEF)ZWORK(:,JL)=ZMEAN(JL) 00474 WRITE(YPATCH,'(I2.2)')JL 00475 YSUFFIX='S'//YPATCH//'_' 00476 CALL FAIENC(KRESP,NUNIT_FA,YSUFFIX,0,HREC,ZWORK(:,JL),.FALSE.) 00477 IF (KRESP/=0) CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00478 END DO 00479 ENDIF 00480 ! 00481 !$OMP END SINGLE COPYPRIVATE(KRESP) 00482 ! 00483 #ifndef NOMPI 00484 XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0) 00485 #endif 00486 ! 00487 ENDIF 00488 ! 00489 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',1,ZHOOK_HANDLE) 00490 ! 00491 END SUBROUTINE WRITE_SURFX2_FA 00492 ! 00493 ! ############################################################# 00494 SUBROUTINE WRITE_SURFN1_FA(HREC,KL,KFIELD,KRESP,HCOMMENT,HDIR) 00495 ! ############################################################# 00496 ! 00497 !!**** * - routine to write an integer array 00498 ! 00499 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE 00500 ! 00501 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, NMASK, NFULL, CMASK, LFANOCOMPACT 00502 ! 00503 USE MODE_FASURFEX 00504 ! 00505 USE MODI_IO_BUFF_n 00506 USE MODI_ERROR_WRITE_SURF_FA 00507 USE MODI_GATHER_AND_WRITE_MPI 00508 ! 00509 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00510 USE PARKIND1 ,ONLY : JPRB 00511 ! 00512 IMPLICIT NONE 00513 ! 00514 #ifndef NOMPI 00515 INCLUDE "mpif.h" 00516 #endif 00517 ! 00518 !* 0.1 Declarations of arguments 00519 ! 00520 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00521 INTEGER, INTENT(IN) :: KL ! number of points 00522 INTEGER, DIMENSION(KL), INTENT(IN) :: KFIELD ! array containing the data field 00523 INTEGER, INTENT(OUT):: KRESP ! KRESP : return-code if a problem appears 00524 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00525 CHARACTER(LEN=1), INTENT(IN) :: HDIR ! type of field : 00526 ! 'H' : field with 00527 ! horizontal spatial dim. 00528 ! '-' : no horizontal dim. 00529 !* 0.2 Declarations of local variables 00530 ! 00531 CHARACTER(LEN=18) :: YNAME! Field Nam 00532 LOGICAL :: GKNOWN 00533 INTEGER :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00534 INTEGER, DIMENSION(MAX(NFULL,SIZE(KFIELD))) :: IWORK ! work array read in the file 00535 DOUBLE PRECISION :: XTIME0 00536 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00537 ! 00538 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',0,ZHOOK_HANDLE) 00539 ! 00540 KRESP = 0 00541 ! 00542 !$OMP SINGLE 00543 ! 00544 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00545 ! 00546 !$OMP END SINGLE COPYPRIVATE(GKNOWN) 00547 ! 00548 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',1,ZHOOK_HANDLE) 00549 IF (GKNOWN) RETURN 00550 ! 00551 IF (HDIR/='H' .OR. HREC=="-") THEN 00552 IWORK(1:KL) = KFIELD 00553 ELSE 00554 CALL GATHER_AND_WRITE_MPI(KFIELD,IWORK,NMASK) 00555 ENDIF 00556 ! 00557 IF (NRANK==NPIO) THEN 00558 ! 00559 #ifndef NOMPI 00560 XTIME0 = MPI_WTIME() 00561 #endif 00562 ! 00563 !$OMP SINGLE 00564 ! 00565 IF(LFANOCOMPACT)THEN 00566 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00567 ! -- Pour ecrire sans compactage 00568 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00569 ENDIF 00570 ! 00571 YNAME=TRIM(CMASK)//TRIM(HREC) 00572 ! 00573 CALL FAECR_I_D(KRESP,NUNIT_FA,YNAME,KL,IWORK(1:KL)) 00574 IF (KRESP/=0) CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00575 ! 00576 IF(LFANOCOMPACT)THEN 00577 ! On remet la valeur par defaut 00578 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00579 ENDIF 00580 ! 00581 !$OMP END SINGLE COPYPRIVATE(KRESP) 00582 ! 00583 #ifndef NOMPI 00584 XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0) 00585 #endif 00586 ! 00587 ENDIF 00588 ! 00589 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',1,ZHOOK_HANDLE) 00590 RETURN 00591 ! 00592 END SUBROUTINE WRITE_SURFN1_FA 00593 ! 00594 ! ############################################################# 00595 SUBROUTINE WRITE_SURFL1_FA(HREC,KL,OFIELD,KRESP,HCOMMENT,HDIR) 00596 ! ############################################################# 00597 ! 00598 !!**** * - routine to write a logical array 00599 ! 00600 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE 00601 ! 00602 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, LFANOCOMPACT 00603 ! 00604 USE MODE_FASURFEX 00605 ! 00606 USE MODI_IO_BUFF_n 00607 USE MODI_ERROR_WRITE_SURF_FA 00608 ! 00609 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00610 USE PARKIND1 ,ONLY : JPRB 00611 ! 00612 IMPLICIT NONE 00613 ! 00614 #ifndef NOMPI 00615 INCLUDE "mpif.h" 00616 #endif 00617 ! 00618 !* 0.1 Declarations of arguments 00619 ! 00620 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00621 INTEGER, INTENT(IN) :: KL ! number of points 00622 LOGICAL, DIMENSION(KL), INTENT(IN) :: OFIELD ! array containing the data field 00623 INTEGER, INTENT(OUT):: KRESP ! KRESP : return-code if a problem appears 00624 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00625 CHARACTER(LEN=1), INTENT(IN) :: HDIR ! type of field : 00626 ! 'H' : field with 00627 ! horizontal spatial dim. 00628 ! '-' : no horizontal dim. 00629 !* 0.2 Declarations of local variables 00630 ! 00631 CHARACTER(LEN=18):: YNAME ! Field Name 00632 LOGICAL :: GKNOWN 00633 INTEGER :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00634 DOUBLE PRECISION :: XTIME0 00635 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00636 ! 00637 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',0,ZHOOK_HANDLE) 00638 ! 00639 IF (NRANK==NPIO) THEN 00640 ! 00641 #ifndef NOMPI 00642 XTIME0 = MPI_WTIME() 00643 #endif 00644 ! 00645 KRESP=0 00646 ! 00647 !$OMP SINGLE 00648 ! 00649 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00650 ! 00651 !$OMP END SINGLE COPYPRIVATE(GKNOWN) 00652 ! 00653 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',1,ZHOOK_HANDLE) 00654 IF (GKNOWN) RETURN 00655 ! 00656 !$OMP SINGLE 00657 ! 00658 IF(LFANOCOMPACT)THEN 00659 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00660 ! -- Pour ecrire sans compactage 00661 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00662 ENDIF 00663 ! 00664 YNAME=TRIM(CMASK)//TRIM(HREC) 00665 CALL FAECR_L_D(KRESP,NUNIT_FA,YNAME,KL,OFIELD) 00666 IF (KRESP/=0) CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00667 ! 00668 IF(LFANOCOMPACT)THEN 00669 ! On remet la valeur par defaut 00670 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00671 ENDIF 00672 ! 00673 !$OMP END SINGLE COPYPRIVATE(KRESP) 00674 ! 00675 #ifndef NOMPI 00676 XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0) 00677 #endif 00678 ! 00679 ENDIF 00680 ! 00681 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',1,ZHOOK_HANDLE) 00682 ! 00683 END SUBROUTINE WRITE_SURFL1_FA 00684 ! 00685 ! ############################################################# 00686 SUBROUTINE WRITE_SURFT0_FA(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT) 00687 ! ############################################################# 00688 ! 00689 !!**** * - routine to write a date 00690 ! 00691 USE MODD_IO_SURF_FA, ONLY : CMASK, NUNIT_FA, LFANOCOMPACT 00692 ! 00693 USE MODE_FASURFEX 00694 ! 00695 USE MODI_IO_BUFF_n 00696 USE MODI_ERROR_WRITE_SURF_FA 00697 ! 00698 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00699 USE PARKIND1 ,ONLY : JPRB 00700 ! 00701 IMPLICIT NONE 00702 ! 00703 !* 0.1 Declarations of arguments 00704 ! 00705 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00706 INTEGER, INTENT(IN) :: KYEAR ! year 00707 INTEGER, INTENT(IN) :: KMONTH ! month 00708 INTEGER, INTENT(IN) :: KDAY ! day 00709 REAL, INTENT(IN) :: PTIME ! time 00710 INTEGER, INTENT(OUT) :: KRESP ! KRESP : return-code if a problem appears 00711 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00712 00713 !* 0.2 Declarations of local variables 00714 ! 00715 CHARACTER(LEN=18) :: YNAME ! Field Name 00716 LOGICAL :: GKNOWN 00717 INTEGER :: IRET 00718 INTEGER :: IHOUR, IMIN 00719 INTEGER :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL 00720 INTEGER, DIMENSION(3) :: ITDATE 00721 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00722 ! 00723 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',0,ZHOOK_HANDLE) 00724 ! 00725 KRESP=0 00726 ! 00727 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00728 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',1,ZHOOK_HANDLE) 00729 IF (GKNOWN) RETURN 00730 ! 00731 IF (HREC=='DTCUR') THEN 00732 IHOUR = NINT(PTIME)/3600 00733 IMIN = NINT(PTIME)/60 - IHOUR * 60 00734 CALL FANDAR(IRET,NUNIT_FA,(/ KYEAR, KMONTH, KDAY, IHOUR, IMIN, 1, 0, 0, 0, 0, 0 /)) 00735 END IF 00736 ! 00737 ITDATE(1) = KYEAR 00738 ITDATE(2) = KMONTH 00739 ITDATE(3) = KDAY 00740 ! 00741 IF(LFANOCOMPACT)THEN 00742 CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00743 ! -- Pour ecrire sans compactage 00744 CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00745 ENDIF 00746 ! 00747 YNAME=TRIM(CMASK)//TRIM(HREC)//'%TDATE' 00748 CALL FAECR_I_D(KRESP,NUNIT_FA,YNAME,3,ITDATE) 00749 IF (KRESP/=0) THEN 00750 CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00751 ENDIF 00752 ! 00753 YNAME=TRIM(CMASK)//TRIM(HREC)//'%TIME' 00754 CALL FAECR_R(KRESP,NUNIT_FA,YNAME,PTIME) 00755 IF (KRESP/=0) THEN 00756 CALL ERROR_WRITE_SURF_FA(HREC,KRESP) 00757 ENDIF 00758 ! 00759 IF(LFANOCOMPACT)THEN 00760 ! On remet la valeur par defaut 00761 CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL) 00762 ENDIF 00763 ! 00764 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',1,ZHOOK_HANDLE) 00765 ! 00766 END SUBROUTINE WRITE_SURFT0_FA 00767 ! 00768 ! ############################################################# 00769 SUBROUTINE WRITE_SURFT2_FA(HREC,KL1,KL2,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT) 00770 ! ############################################################# 00771 ! 00772 !!**** * - routine to write a date 00773 ! 00774 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE 00775 ! 00776 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, NLUOUT 00777 ! 00778 USE MODE_FASURFEX 00779 ! 00780 USE MODI_IO_BUFF_n 00781 USE MODI_ABOR1_SFX 00782 USE MODI_ERROR_WRITE_SURF_FA 00783 ! 00784 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00785 USE PARKIND1 ,ONLY : JPRB 00786 ! 00787 IMPLICIT NONE 00788 ! 00789 #ifndef NOMPI 00790 INCLUDE "mpif.h" 00791 #endif 00792 ! 00793 !* 0.1 Declarations of arguments 00794 ! 00795 CHARACTER(LEN=12), INTENT(IN) :: HREC ! name of the article to be read 00796 INTEGER, INTENT(IN) :: KL1 ! number of points 00797 INTEGER, INTENT(IN) :: KL2 ! 2nd dimension 00798 INTEGER, DIMENSION(KL1,KL2), INTENT(IN) :: KYEAR ! year 00799 INTEGER, DIMENSION(KL1,KL2), INTENT(IN) :: KMONTH ! month 00800 INTEGER, DIMENSION(KL1,KL2), INTENT(IN) :: KDAY ! day 00801 REAL, DIMENSION(KL1,KL2), INTENT(IN) :: PTIME ! time 00802 INTEGER, INTENT(OUT) :: KRESP ! KRESP : return-code if a problem appears 00803 CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string 00804 00805 !* 0.2 Declarations of local variables 00806 ! 00807 CHARACTER(LEN=18):: YNAME ! Field Name 00808 LOGICAL :: GKNOWN 00809 INTEGER, DIMENSION(3,SIZE(KYEAR,1),SIZE(KYEAR,2)) :: ITDATE 00810 DOUBLE PRECISION :: XTIME0 00811 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00812 ! 00813 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',0,ZHOOK_HANDLE) 00814 ! 00815 IF (NRANK==NPIO) THEN 00816 ! 00817 #ifndef NOMPI 00818 XTIME0 = MPI_WTIME() 00819 #endif 00820 ! 00821 KRESP=0 00822 ! 00823 !$OMP SINGLE 00824 ! 00825 CALL IO_BUFF_n(HREC,'W',GKNOWN) 00826 ! 00827 !$OMP END SINGLE COPYPRIVATE(GKNOWN) 00828 ! 00829 IF (GKNOWN .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',1,ZHOOK_HANDLE) 00830 IF (GKNOWN) RETURN 00831 ! 00832 !$OMP SINGLE 00833 ! 00834 ITDATE(1,:,:) = KYEAR (:,:) 00835 ITDATE(2,:,:) = KMONTH (:,:) 00836 ITDATE(3,:,:) = KDAY (:,:) 00837 ! 00838 !$OMP END SINGLE 00839 ! 00840 YNAME=TRIM(CMASK)//TRIM(HREC) 00841 WRITE(NLUOUT,*) ' WRITE_SURFT2_FA : time in 2 dimensions not yet implemented : YNAME=',YNAME,'ITDATE=',ITDATE 00842 CALL ABOR1_SFX('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA: time in 2 dimensions not yet implemented') 00843 ! 00844 #ifndef NOMPI 00845 XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0) 00846 #endif 00847 ! 00848 ENDIF 00849 ! 00850 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',1,ZHOOK_HANDLE) 00851 ! 00852 END SUBROUTINE WRITE_SURFT2_FA 00853 ! 00854 END MODULE MODE_WRITE_SURF_FA
1.8.0
