|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 C Jan-2011 P. Marguinaud Thread-safe FA 00002 SUBROUTINE FARPAR_MT (FA, KREP, CDPREF, CDSUFF, KCODPA, KNUM ) 00003 USE FA_MOD, ONLY : FA_COM 00004 USE PARKIND1, ONLY : JPRB 00005 USE YOMHOOK , ONLY : LHOOK, DR_HOOK 00006 C**** 00007 C Sous-programme de reglage de la correspondance "nom d'article FA" 00008 C <-> "descripteurs GRIB du parametre+niveau" 00009 C** 00010 C Arguments : KREP (Sortie) ==> Code-reponse du sous-programme; 00011 C ( Tableau ) CDPREF (Entree) ==> Prefixe pour les KNUM noms d'article; 00012 C ( Tableau ) CDSUFF (Entree) ==> Suffixe pour les KNUM noms d'article; 00013 C ( Tableau ) KCODPA (Entree) ==> 6 descripteurs GRIB pour chacun 00014 C des KNUM parametres: 00015 C KCODPA(J,1) = KSEC1(1) version de la table parametres 00016 C KCODPA(J,2) = KSEC1(6) indicateur du parametre 00017 C KCODPA(J,3) = KSEC1(7) indicateur du type de niveau 00018 C KCODPA(J,4) = KSEC1(8) niveau 00019 C KCODPA(J,5) = KSEC1(9) 2ieme nv si couche, sinon 0 00020 C KCODPA(J,6) = KSEC1(18) indicateur du type de champ 00021 C (0 sf si min/max:2 ou si cumul:4) 00022 C 00023 C KNUM (Entree ==> Nombre de parametres a regler 00024 C et (dimension de CDPREF, CDSUFF et KCODPA) 00025 C Sortie) ==> Nb de nouveaux parametres pouvant encore 00026 C etre definis lors d'un appel ulterieur. 00027 C 00028 #include "precision.h" 00029 C 00030 C 00031 TYPE(FA_COM) :: FA 00032 INTEGER KREP, KNUM 00033 INTEGER KCODPA(KNUM,6) 00034 C 00035 CHARACTER (LEN=*) CDPREF(KNUM), CDSUFF(KNUM) 00036 C 00037 INTEGER J, JJ, INUMER, INIMES, JMEM 00038 #include "facom_mt.h" 00039 C 00040 INTRINSIC LEN_TRIM 00041 C 00042 C** 00043 C 0. - CONTROLES ET INITIALISATIONS PREALABLES 00044 C----------------------------------------------------------------------- 00045 C 00046 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00047 IF (LHOOK) CALL DR_HOOK('FARPAR_MT',0,ZHOOK_HANDLE) 00048 IF (KNUM.LT.1) THEN 00049 KREP=-129 00050 IF (FA%LFAMOP) THEN 00051 WRITE (UNIT=FA%NULOUT,FMT=*) 00052 S 'FARPAR: Nb de parametres ',KNUM,' incorrect' 00053 ENDIF 00054 GOTO 1001 00055 ENDIF 00056 DO J = 1,KNUM 00057 IF ( LEN_TRIM(CDPREF(J)).LE.0 .OR. 00058 S LEN_TRIM(CDPREF(J)).GT.FA%JPXPRF ) THEN 00059 KREP=-129 00060 IF (FA%LFAMOP) THEN 00061 WRITE (UNIT=FA%NULOUT,FMT=*) 00062 S 'FARPAR: Longueur du prefixe ',CDPREF(J), 00063 S ' incorrecte : ',LEN_TRIM(CDPREF(J)) 00064 ENDIF 00065 GOTO 1001 00066 ENDIF 00067 IF ( LEN_TRIM(CDSUFF(J)).LE.0 .OR. 00068 S LEN_TRIM(CDSUFF(J)).GT.FA%JPXNOM-LEN_TRIM(CDPREF(J)) ) THEN 00069 KREP=-129 00070 IF (FA%LFAMOP) THEN 00071 WRITE (UNIT=FA%NULOUT,FMT=*) 00072 S 'FARPAR: Longueur du suffixe ',CDSUFF(J), 00073 S ' incorrecte : ',LEN_TRIM(CDSUFF(J)) 00074 ENDIF 00075 GOTO 1001 00076 ENDIF 00077 DO JJ = 1,3 00078 IF (KCODPA(J,JJ).LT.1 .OR. KCODPA(J,JJ).GT.255) THEN 00079 KREP=-129 00080 IF (FA%LFAMOP) THEN 00081 WRITE (UNIT=FA%NULOUT,FMT=*) 00082 S 'FARPAR: descripteur GRIB num ',JJ, 00083 S ' pour le parametre num ',J,' ( ', 00084 S CDPREF(J)//CDSUFF(J),' ) incorrect : ', 00085 S KCODPA(J,JJ) 00086 ENDIF 00087 GOTO 1001 00088 ENDIF 00089 ENDDO 00090 IF (KCODPA(J,6).LT.0 .OR. KCODPA(J,6).GT.124) THEN 00091 KREP=-129 00092 IF (FA%LFAMOP) THEN 00093 WRITE (UNIT=FA%NULOUT,FMT=*) 00094 S 'FARPAR: descripteur GRIB, KSEC1(18),', 00095 S ' pour le parametre num ',J,' ( ', 00096 S CDPREF(J)//CDSUFF(J),' ) incorrect : ', 00097 S KCODPA(J,6) 00098 ENDIF 00099 GOTO 1001 00100 ENDIF 00101 IF (KCODPA(J,4).LT.0) THEN 00102 KREP=-129 00103 IF (FA%LFAMOP) THEN 00104 WRITE (UNIT=FA%NULOUT,FMT=*) 00105 S 'FARPAR: descripteur GRIB, KSEC1(8),', 00106 S ' pour le parametre num ',J,' ( ', 00107 S CDPREF(J)//CDSUFF(J),' ) incorrect : ', 00108 S KCODPA(J,4) 00109 ENDIF 00110 GOTO 1001 00111 ENDIF 00112 ENDDO 00113 C 00114 C** 00115 C 2. - Prise en compte des nouvelles correspondances 00116 C--------------------------------------------------------- 00117 C 00118 C 00119 DO J = 1,KNUM 00120 C Recherche prealable de l'eventuelle existence de la definition 00121 C de ce parametre (il faudra alors l'ecraser). 00122 JMEM = 0 00123 DO JJ = 1,FA%NBPARC 00124 IF (CDPREF(J )(1:LEN_TRIM(CDPREF(J ))).EQ. 00125 S FA%CIPREF(JJ)(1:LEN_TRIM(FA%CIPREF(JJ))) .AND. 00126 S CDSUFF(J )(1:LEN_TRIM(CDSUFF(J ))).EQ. 00127 S FA%CISUFF(JJ)(1:LEN_TRIM(FA%CISUFF(JJ)))) THEN 00128 JMEM = JJ 00129 EXIT 00130 ENDIF 00131 ENDDO 00132 IF (JMEM==0) THEN 00133 IF (FA%NBPARC+1.GT.FA%JPXPAR) THEN 00134 KREP=-129 00135 IF (FA%LFAMOP) THEN 00136 WRITE (UNIT=FA%NULOUT,FMT=*) 00137 S 'FARPAR: le nb lim de parametres definissables ', 00138 S FA%JPXPAR 00139 WRITE (UNIT=FA%NULOUT,FMT=*) 00140 S ' est depasse avec la definition de ', 00141 S KNUM,' nouveaux parametres' 00142 ENDIF 00143 GOTO 1001 00144 ENDIF 00145 JMEM = FA%NBPARC + 1 00146 FA%NBPARC = FA%NBPARC + 1 00147 ENDIF 00148 FA%CIPREF(JMEM) = 00149 S CDPREF(J)(1:LEN_TRIM(CDPREF(J))) 00150 FA%CISUFF(JMEM) = 00151 S CDSUFF(J)(1:LEN_TRIM(CDSUFF(J))) 00152 FA%NCODPA(JMEM,1:6) = KCODPA(J,1:6) 00153 IF (FA%LFAMOP) THEN 00154 WRITE (UNIT=FA%NULOUT,FMT=*) 00155 S 'FARPAR: Prise en compte de ',CDPREF(J)//CDSUFF(J) 00156 WRITE (UNIT=FA%NULOUT,FMT=*) 00157 S ' associe a KSEC1(1,6:9 et 18) = ', 00158 S FA%NCODPA(JMEM,1:6) 00159 ENDIF 00160 ENDDO 00161 KNUM = FA%JPXPAR - FA%NBPARC 00162 C 00163 C** 00164 C 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL, 00165 C VIA LE SOUS-PROGRAMME "FAIPAR" . 00166 C----------------------------------------------------------------------- 00167 C 00168 1001 CONTINUE 00169 C 00170 IF (FA%LFAMOP) THEN 00171 INIMES=2 00172 CLNSPR='FARPAR' 00173 INUMER=FA%JPNIIL 00174 C 00175 WRITE (UNIT=CLMESS,FMT='(''KREP='',I4)') KREP 00176 CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS, 00177 S CLNSPR,CLNSPR,.FALSE.) 00178 ENDIF 00179 C 00180 IF (LHOOK) CALL DR_HOOK('FARPAR_MT',1,ZHOOK_HANDLE) 00181 END 00182
1.8.0
