1 : C EXTR20 SOURCE FANDEUR 10/12/09 21:15:03 6810 2 : 3 : SUBROUTINE EXTR20 (IPCHAR,CMOT,ICHGT,LCHGT,IEC, 4 : & IPRES1,CTYP1,IPRES2,CTYP2) 5 : 6 : C======================================================================= 7 : C 8 : C RESULTAT = EXTRAIRE CHARGEME ... ; 9 : C 10 : C 1) CHARGEME 'CHAR' (ENTIER) CHARGEME 11 : C 2) CHARGEME 'CHAM' (ENTIER) CHPOINT ou MCHAML 12 : C 3) CHARGEME 'TRAJ' (ENTIER) CHPOINT 13 : C 4) CHARGEME 'EVOL' (ENTIER) EVOLUTION 14 : C 5) CHARGEME 'VITE' (ENTIER) EVOLUTION 15 : C 6) CHARGEME 'COMP' LISTMOTS 16 : C 7) CHARGEME 'LIE ' CHARGEME 17 : C 8) CHARGEME 'LIBR' CHARGEME 18 : C 9) CHARGEME MOT 'TABLES' TABLES 19 : C 10) CHARGEME MOT CHARGEME 20 : C 11) CHARGEME LISTMOTS CHARGEME 21 : C 22 : C======================================================================= 23 : 24 : IMPLICIT INTEGER(I-N) 25 : IMPLICIT REAL*8(A-H,O-Z) 26 : 27 : -INC CCOPTIO 28 : -INC CCGEOME 29 : 30 : -INC SMCHARG 31 : -INC SMEVOLL 32 : -INC SMLMOTS 33 : 34 : CHARACTER*(4) CMOT 35 : CHARACTER*(8) CTYP1,CTYP2 36 : 37 : CHARACTER*4 MCOMP 38 : 39 : IPRES1 = 0 40 : CTYP1 = ' ' 41 : IPRES2 = 0 42 : CTYP2 = ' ' 43 : 44 : MCHARG = IPCHAR 45 : SEGACT,MCHARG 46 : NCHAR = KCHARG(/1) 47 : C 48 : IF (NCHAR.LT.IEC) THEN 49 : INTERR(1) = IEC 49 : CALL ERREUR(690) 50 : GOTO 9999 51 : ENDIF 52 : C 53 : ICHG2 = ICHGT + 2 54 : GOTO ( 1010, 1000, 10, 20, 30, 40, 50, 60, 70, 70), ICHG2 55 : GOTO 9999 56 : C 57 : C MOT-CLE 'CHAR' ==> ICHGT = 1 58 : C---------------- 59 : 10 CONTINUE 60 : N = 1 61 : SEGINI,MCHAR1 62 : MCHAR1.KCHARG(1) = KCHARG(IEC) 63 : MCHAR1.CHANOM(1) = CHANOM(IEC) 64 : MCHAR1.CHANAT(1) = CHANAT(IEC) 65 : MCHAR1.CHAMOB(1) = CHAMOB(IEC) 66 : MCHAR1.CHALIE(1) = CHALIE(IEC) 67 : SEGDES,MCHAR1 68 : IPRES1 = MCHAR1 69 : CTYP1 = 'CHARGEME' 70 : GOTO 9999 71 : C 72 : C MOT-CLE 'CHAM' ==> ICHGT = 2 73 : C---------------- 74 : 20 CONTINUE 75 : ICHARG = KCHARG(IEC) 76 : SEGACT,ICHARG 77 : IF (CHATYP.EQ.'CHPOINT ' .OR. CHATYP.EQ.'MCHAML ') THEN 78 : IPRES1 = ICHPO1 79 : CTYP1 = CHATYP 80 : ELSE 81 : INTERR(1) = IEC 81 : CALL ERREUR(688) 82 : ENDIF 83 : SEGDES,ICHARG 84 : GOTO 9999 85 : C 86 : C MOT-CLE 'TRAJ' ==> ICHGT = 3 87 : C--------------- 88 : 30 CONTINUE 89 : IF (CHAMOB(IEC).EQ.'TRAJ') THEN 90 : ICHARG = KCHARG(IEC) 91 : SEGACT,ICHARG 92 : IPRES1 = ICHPO4 93 : CTYP1 = 'CHPOINT' 94 : SEGDES,ICHARG 95 : ELSE 96 : INTERR(1) = IEC 96 : CALL ERREUR(900) 97 : ENDIF 98 : GOTO 9999 99 : C 100 : C MOT-CLE 'EVOL' ==> ICHGT = 4 101 : C--------------- 102 : 40 CONTINUE 103 : ICHARG = KCHARG(IEC) 104 : SEGACT,ICHARG 105 : IF (CHATYP.EQ.'CHPOINT ' .OR. CHATYP.EQ.'MCHAML ') THEN 106 : SEGINI,KEVOLL 107 : NUMEVX = IDCOUL 108 : NUMEVY = 'REEL' 109 : TYPX = 'LISTREEL' 110 : TYPY = 'LISTREEL' 111 : NOMEVX = 'TEMPS' 112 : NOMEVY = CHANOM(IEC) 113 : IPROGX = ICHPO2 114 : IPROGY = ICHPO3 115 : KEVTEX = 'Evolution temporelle de '//CHANOM(IEC) 116 : SEGDES,KEVOLL 117 : N = 1 118 : SEGINI,MEVOLL 119 : ITYEVO = 'REEL' 120 : IEVTEX = 'Evolution extraite d''un CHARGEMENT' 121 : IEVOLL(1) = KEVOLL 122 : SEGDES,MEVOLL 123 : IPRES1 = MEVOLL 124 : CTYP1 = 'EVOLUTIO' 125 : ELSE 126 : INTERR(1) = IEC 126 : CALL ERREUR(689) 127 : ENDIF 128 : SEGDES,ICHARG 129 : GOTO 9999 130 : C 131 : C MOT-CLE 'VITE' ==> ICHGT = 5 132 : C--------------- 133 : 50 CONTINUE 134 : IF (CHAMOB(IEC).EQ.'TRAN' .OR. CHAMOB(IEC).EQ.'ROTA') THEN 135 : ICHARG = KCHARG(IEC) 136 : SEGACT,ICHARG 137 : SEGINI,KEVOLL 138 : NUMEVX = IDCOUL 139 : NUMEVY = 'REEL' 140 : TYPX = 'LISTREEL' 141 : TYPY = 'LISTREEL' 142 : IPROGX = ICHPO6 143 : IPROGY = ICHPO7 144 : NOMEVX = 'TEMPS' 145 : NOMEVY = CHANOM(IEC) 146 : KEVTEX='Evolution temporelle de '//CHANOM(IEC) 147 : SEGDES,KEVOLL 148 : SEGDES,ICHARG 149 : N = 1 150 : SEGINI,MEVOLL 151 : ITYEVO = 'REEL' 152 : IEVTEX = 'Evolution extraite d''un CHARGEMENT' 153 : IEVOLL(1) = KEVOLL 154 : SEGDES,MEVOLL 155 : IPRES1 = MEVOLL 156 : CTYP1 = 'EVOLUTIO' 157 : ELSE 158 : INTERR(1) = IEC 158 : CALL ERREUR(901) 159 : ENDIF 160 : GOTO 9999 161 : 162 : C MOT-CLE 'COMP' ==> ICHGT = 6 163 : C---------------- 164 : 60 CONTINUE 165 : JGN = 4 166 : JGM = NCHAR 167 : SEGINI,MLMOTS 168 : MOTS(1) = CHANOM(1) 169 : NMO1 = 1 170 : DO icha = 2, NCHAR 171 : DO kcha = 1, NMO1 172 : IF (CHANOM(icha).EQ.MOTS(kcha)) GOTO 61 173 : ENDDO 174 : NMO1 = NMO1 + 1 175 : MOTS(NMO1) = CHANOM(icha) 176 : 61 CONTINUE 177 : ENDDO 178 : IF (JGM.NE.NMO1) THEN 179 : JGM = NMO1 180 : SEGADJ,MLMOTS 181 : ENDIF 182 : SEGDES,MLMOTS 183 : IPRES1 = MLMOTS 184 : CTYP1 = 'LISTMOTS' 185 : GOTO 9999 186 : C 187 : C MOT-CLE 'LIE ' OU 'LIBR' ==> ICHGT = 7 ou 8 188 : C-------------------------- 189 : 70 CONTINUE 190 : N = NCHAR 191 : SEGINI,MCHAR1 192 : kcha = 0 193 : DO icha = 1, NCHAR 194 : IF (CHALIE(icha).EQ.CMOT) then 195 : kcha = kcha + 1 196 : MCHAR1.KCHARG(kcha) = KCHARG(icha) 197 : MCHAR1.CHANAT(kcha) = CHANAT(icha) 198 : MCHAR1.CHANOM(kcha) = CHANOM(icha) 199 : MCHAR1.CHAMOB(kcha) = CHAMOB(icha) 200 : MCHAR1.CHALIE(kcha) = CHALIE(icha) 201 : ENDIF 202 : ENDDO 203 : IF (kcha.LE.0) THEN 204 : SEGSUP,MCHAR1 205 : MOTERR(1:4) = CMOT 205 : CALL ERREUR(899) 206 : ELSE 207 : IF (kcha.NE.N) THEN 208 : N = kcha 209 : SEGADJ,MCHAR1 210 : ENDIF 211 : SEGDES,MCHAR1 212 : IPRES1 = MCHAR1 213 : CTYP1 = 'CHARGEME' 214 : ENDIF 215 : GOTO 9999 216 : 217 : C COMPOSANTE MOT ou LISTMOTS ==> ICHGT = 0 218 : C---------------------------- 219 : 1000 CONTINUE 220 : N = NCHAR 221 : SEGINI,MCHAR1 222 : NCOMP = 1 223 : MCOMP = CMOT 224 : MLMOTS = LCHGT 225 : IF (LCHGT.GT.0) THEN 226 : SEGACT,MLMOTS 227 : NCOMP = MLMOTS.MOTS(/2) 228 : ENDIF 229 : 230 : kcha = 0 231 : DO icomp = 1, NCOMP 232 : IF (LCHGT.GT.0) MCOMP = MLMOTS.MOTS(icomp) 233 : kcha1 = 0 234 : DO icha = 1, NCHAR 235 : IF (CHANOM(icha).EQ.MCOMP) THEN 236 : kcha = kcha + 1 237 : MCHAR1.KCHARG(kcha) = KCHARG(icha) 238 : MCHAR1.CHANAT(kcha) = CHANAT(icha) 239 : MCHAR1.CHANOM(kcha) = CHANOM(icha) 240 : MCHAR1.CHAMOB(kcha) = CHAMOB(icha) 241 : MCHAR1.CHALIE(kcha) = CHALIE(icha) 242 : kcha1 = 1 243 : ENDIF 244 : ENDDO 245 : IF (kcha1.EQ.0) THEN 246 : MOTERR(1:4) = MCOMP 246 : CALL ERREUR(685) 247 : ENDIF 248 : ENDDO 249 : IF (LCHGT.GT.0) SEGDES,MLMOTS 250 : 251 : IF (IERR.EQ.0) THEN 252 : IF (kcha.NE.N) THEN 253 : N = kcha 254 : SEGADJ,MCHAR1 255 : ENDIF 256 : SEGDES,MCHAR1 257 : IPRES1 = MCHAR1 258 : CTYP1 = 'CHARGEME' 259 : ELSE 260 : SEGSUP,MCHAR1 261 : ENDIF 262 : GOTO 9999 263 : 264 : C TABLES DE CHARGEMENT DE LA COMPOSANTE CMOT ==> ICHGT = -1 265 : C-------------------------------------------- 266 : 1010 CONTINUE 267 : kcha = 0 268 : DO icha = 1, NCHAR 269 : IF (CHANOM(icha).EQ.CMOT) THEN 270 : kcha = kcha + 1 271 : ICHARG = KCHARG(icha) 272 : ENDIF 273 : ENDDO 274 : IF (kcha.NE.1) THEN 275 : IF (kcha.EQ.0) THEN 276 : MOTERR(1:4) = CMOT 276 : CALL ERREUR(685) 277 : ELSE 277 : CALL ERREUR(697) 277 : CALL ERREUR(512) 278 : ENDIF 279 : ELSE 280 : SEGACT,ICHARG 281 : IPRES1 = ICHPO2 282 : CTYP1 = 'TABLE ' 283 : IPRES2 = ICHPO1 284 : CTYP2 = 'TABLE ' 285 : SEGDES,ICHARG 286 : * Mettre une verification sur le type de ichpo1 et ichpo2 : TABLE ? 287 : ENDIF 288 : GOTO 9999 289 : 290 : 9999 CONTINUE 291 : SEGDES,MCHARG 292 : 293 : RETURN 294 : END 295 : 296 : 297 :
© Cast3M 2003 - All rights reserved.
Disclaimer