1 : C OPTION SOURCE FANDEUR 14/01/16 21:15:11 7906 2 : 3 : C======================================================================= 4 : C Si ICHOI=1 5 : C Affection d'une valeur a une variable de CCOPTIO (directive OPTION) 6 : C Si ICHOI=2 7 : C Renvoie la valeur d'une des variables de CCOPTIO (directive VALEUR) 8 : C======================================================================= 9 : 10 : SUBROUTINE OPTION (ICHOI) 11 : 12 : IMPLICIT INTEGER(I-N) 13 : IMPLICIT REAL*8 (A-H,O-Z) 14 : 15 : -INC CCOPTIO 16 : -INC CCGEOME 17 : -INC CCHAMP 18 : -INC CCASSIS 19 : -INC SMCOORD 20 : -INC SMLREEL 21 : -INC SMLMOTS 22 : -INC CCFXDR 23 : -INC CCTRACE 24 : 25 : SEGMENT MCOOR1 26 : REAL*8 XCoor1(LCoor) 27 : END SEGMENT 28 : 29 : 30 : C NbOpt : Nombre d'options (mot-cles) des operateurs OPTION et VALEUR 31 : C NbMfo : Nombre d'options mot-cle 'MODE' (vecteur MFO) 32 : C NbMsfo : " " mot-cle 'MODE' 'PLAN' (vecteur MSFO) 33 : C NbNoha : " " mot-cle 'FOUR' (vecteur NOHR) 34 : C NbUnid : " " mot-cle 'UNID' (vecteur OptUnid) 35 : C NbMod1D : " " mots-cles 'UNID' 'PLAN','AXIS' (vect. Mode1D) 36 : C NbGra : " " mot-cle 'TRAC' (vecteur MGR) 37 : C NbIso : " " mot-cle 'ISOV' (vecteur MISO) 38 : C NbReso : " " mot-cle 'RESO' (vecteur MRESOL) 39 : C NbErre : " " mot-cle 'ERRE' (vecteur ERCTRL) 40 : C NbForm : " " mot-cle 'SAUV' et 'REST' (vecteur FORMAT) 41 : C NbAuto : " " mot-cle 'NORM' (vecteur NAUTO) 42 : PARAMETER (NbOpt=42,NbMfo=6,NbMsfo=3,NbNoha=1,NbUnid=3,NbMod1D=12, 43 : $ NbGra=9,NbIso=3,NbReso=2,NbErre=4,NbForm=4,NbAuto=2, 44 : $ NbPoli=7,NbCosc=3,NbPotr=12) 45 : 46 : EXTERNAL LONG 47 : CHARACTER*4 MCLE(NbOpt) 48 : CHARACTER*4 MFO(NbMfo) 49 : CHARACTER*4 MSFO(NbMsfo) 50 : CHARACTER*4 OptUnid(NbUnid) 51 : CHARACTER*4 Mode1D(NbMod1D) 52 : CHARACTER*4 MGR(NbGra) 53 : CHARACTER*4 MISO(NbIso) 54 : CHARACTER*4 MRESOL(NbReso) 55 : CHARACTER*4 ERCTRL(NbErre) 56 : CHARACTER*4 FORMAT(NbForm) 57 : CHARACTER*4 NOHR(NbNoha) 58 : CHARACTER*4 NAUTO(NbAuto) 59 : CHARACTER*8 MPOLI(NbPoli) 60 : CHARACTER*12 ICHA 61 : CHARACTER*4 MCOSC(NbCosc) 62 : CHARACTER*12 MPOTR(NbPotr) 63 : 64 : CHARACTER*512 CHA 65 : CHARACTER*16 MODERI(5) 66 : LOGICAL LOG 67 : 68 : 69 : DATA MCLE / 'IMPR','DIME','ELEM','SORT','TRAC','DONN','ECHO', 70 : $ 'ERRE','LECT','EPSI','IMPI','MODE','CADR','COUL', 71 : $ 'NIVE','NGMA','SAUV','REST','ISOV','OMBR','NBP ', 72 : $ 'VERI','ZERO','ACQU','----','PLAC','LANG','NORM', 73 : $ 'RESO','FTRA','OEIL','ERMA','ASSI','EPTR','NAVI', 74 : $ 'PARA','SURV','POLI','COSC','POTR','DEBU','LOCA' / 75 : DATA MFO / 'TRID','FOUR','AXIS','PLAN','UNID','FREQ' / 76 : DATA MSFO / 'DEFO','CONT','GENE' / 77 : DATA NOHR / 'NOHA' / 78 : DATA OptUnid / 'PLAN','AXIS','SPHE' / 79 : DATA Mode1D / 'DYDZ','DYCZ','CYDZ','CYCZ','GYDZ','GYCZ','DYGZ', 80 : . 'CYGZ','GYGZ','AXDZ','AXCZ','AXGZ' / 81 : DATA MGR / 'BENS','X ','IBM ','GKS ','PHIG','OPEN','PS ', 82 : . 'MIF ','PSC ' / 83 : DATA MISO / 'LIGN','SURF','SULI' / 84 : DATA MRESOL / 'DIRE','ITER' / 85 : DATA ERCTRL / 'FATA','NORM','IGNO','CONT' / 86 : DATA FORMAT / 'FORM','TAIL','XDR','BINA' / 87 : DATA NAUTO / 'AUTO','ANNU' / 88 : DATA MODERI /'LINEAIRE ','QUADRATIQUE ', 89 : $ 'TRUESDELL ','JAUMANN ','UTILISATEUR '/ 90 : DATA MPOLI / '8_BY_13 ','9_BY_15 ','TIMES_10','TIMES_24', 91 : $ 'HELV_10 ','HELV_12 ','HELV_18 ' / 92 : DATA MCOSC / 'NOIR','BLAN','JAUN' / 93 : DATA MPOTR / 'COURIER_12 ','HELVETICA_12','TIMES_12 ', 94 : $ 'COURIER_14 ','HELVETICA_14','TIMES_14 ', 95 : $ 'COURIER_16 ','HELVETICA_16','TIMES_16 ', 96 : $ 'COURIER_18 ','HELVETICA_18','TIMES_18 '/ 97 : 98 : IF ((ICHOI.NE.1).AND.(ICHOI.NE.2)) THEN 98 : CALL ERREUR (5) 99 : RETURN 100 : ENDIF 101 : i=0 102 : 1 CONTINUE 102 : CALL MESLIR(-218) 102 : CALL LIRMOT(MCLE,NBOPT,i,0) 103 : IF (i.EQ.0) RETURN 104 : 105 : C Branchement vers les differentes options 106 : C ------------------------------------------ 107 : GOTO (101,102,103,104,105,106,107,108,109,110,111,112,113,114, 108 : . 115,116,117,118,119,120,121,122,123,124,125,126,127,128, 109 : . 129,130,131,132,133,134,135,136,137,138,139,140,141,142),i 110 : C --------------- 111 : C Option 'IMPR' 112 : C --------------- 113 : 101 IF (ICHOI.EQ.2) THEN 113 : CALL ECRENT(IOIMP) 114 : RETURN 115 : ENDIF 115 : CALL MESLIR(-217) 115 : CALL LIRENT(IRET,0,IRetou) 116 : IF (IRetou.NE.0) THEN 116 : IF (IRET.LE.0) CALL ERREUR(36) 117 : IF (IERR.NE.0) RETURN 118 : IOIMP=IRET 119 : GOTO 1 120 : ENDIF 120 : CALL MESLIR(-216) 120 : CALL LIRCHA(CHA,1,IRetou) 121 : IUNIT=IOIMP 122 : GOTO 1211 123 : C --------------- 124 : C Option 'DIME' : dimension de l'espace (IDIM) 125 : C --------------- 126 : 102 IF (ICHOI.EQ.2) THEN 126 : CALL ECRENT(IDIM) 127 : RETURN 128 : ENDIF 128 : CALL MESLIR(-215) 128 : CALL LIRENT(IRET,1,IRetou) 129 : IF (IRET.EQ.IDIM) GOTO 1 129 : IF ((IRET.NE.1).AND.(IRET.NE.2).AND.(IRET.NE.3)) CALL ERREUR(36) 130 : IF (IERR.NE.0) RETURN 131 : IF (IDIM.EQ.0) THEN 132 : IDIM=IRET 133 : IF (IDIM.EQ.1) THEN 134 : IFOMOD=3 135 : IFOUR=3 136 : NIFOUR=0 137 : ELSE IF (IDIM.EQ.3) THEN 138 : IFOMOD=2 139 : IFOUR=2 140 : NIFOUR=0 141 : ENDIF 142 : GOTO 1 143 : ENDIF 144 : C Passage en dimension 3 145 : IF (IRET.EQ.3) THEN 146 : IFOMOD=2 147 : IFOUR=2 148 : NIFOUR=0 149 : C Passage en dimension 2, on met les options de calcul a PLAN DEFO. 150 : ELSE IF (IRET.EQ.2) THEN 151 : IF (IDIM.EQ.3) THEN 152 : IF (IFOMOD.EQ.2) IFOMOD=-1 153 : IF (IFOUR.EQ.2) IFOUR=-1 154 : ELSE IF (IDIM.EQ.1) THEN 155 : IFOMOD=-1 156 : IFOUR=-1 157 : NIFOUR=0 158 : ENDIF 159 : C Passage en dimension 1, on met les options de calcul a UNIDPLANDYDZ. 160 : ELSE IF (IRET.EQ.1) THEN 161 : IF (IFOMOD.NE.3.AND.IFOMOD.NE.4.AND.IFOMOD.NE.5) THEN 162 : IFOMOD=3 163 : IFOUR=3 164 : NIFOUR=0 165 : ENDIF 166 : ENDIF 167 : C Transfert des coordonnees des points dans nouveau MCOORD 168 : idimp1=IDIM+1 169 : iretp1=IRET+1 170 : NBPTS=XCOOR(/1)/idimp1 171 : LCoor=NBPTS*iretp1 172 : SEGINI,MCOOR1 173 : INF=MIN(IDIM,IRET) 174 : DO IP=1,NBPTS 175 : IRef1=(IP-1)*iretp1 176 : IRef =(IP-1)*idimp1 177 : DO j=1,INF 178 : XCoor1(IRef1+j)=XCOOR(IRef+j) 179 : ENDDO 180 : XCoor1(IRef1+iretp1)=XCOOR(IRef+idimp1) 181 : ENDDO 182 : IDIM=IRET 183 : SEGADJ,MCOORD 184 : DO j=1,XCOOR(/1) 185 : XCOOR(j)=XCOOR1(j) 186 : ENDDO 187 : SEGSUP,MCOOR1 188 : GOTO 1 189 : C --------------- 190 : C Option 'ELEM' 191 : C --------------- 192 : 103 IF (ICHOI.EQ.2) THEN 193 : IF (ILCOUR.EQ.0) THEN 193 : CALL ECRCHA(' ') 194 : ELSE 194 : CALL ECRCHA(NOMS(ILCOUR)) 195 : ENDIF 196 : RETURN 197 : ENDIF 197 : CALL MESLIR(-214) 197 : CALL LIRMOT(NOMS,NOMBR,IRET,1) 198 : IF (IERR.NE.0) RETURN 199 : ILCOUR=IRET 200 : C* ICHA=NOMS(ILCOUR) 201 : GOTO 1 202 : C --------------- 203 : C Option 'SORT' 204 : C --------------- 205 : 104 IF (ICHOI.EQ.2) THEN 205 : CALL ECRENT(IOPER) 206 : RETURN 207 : ENDIF 207 : CALL MESLIR(-213) 207 : CALL LIRENT(IRET,0,IRetou) 208 : IF (IRetou.NE.0) THEN 208 : IF (IRET.LE.0) CALL ERREUR(36) 209 : IF (IERR.NE.0) RETURN 210 : IOPER=IRET 211 : GOTO 1 212 : ENDIF 212 : CALL MESLIR(-212) 212 : CALL LIRCHA(CHA,1,IRetou) 213 : IUNIT=IOPER 214 : GOTO 1211 215 : C --------------- 216 : C Option 'TRAC' 217 : C --------------- 218 : 105 IF (ICHOI.EQ.2) THEN 218 : CALL ECRCHA(MGR(IOGRA)) 219 : RETURN 220 : ENDIF 220 : CALL MESLIR(-211) 220 : CALL LIRMOT(MGR,NbGra,ij,1) 221 : IF (IERR.NE.0) RETURN 222 : IOGRA=ij 223 : GOTO 1 224 : C --------------- 225 : C Option 'DONN' 226 : C --------------- 227 : 106 IF (ICHOI.EQ.2) THEN 227 : CALL ECRENT(IOLEC) 228 : RETURN 229 : ENDIF 229 : CALL MESLIR(-210) 229 : CALL LIRENT(IRET,0,IRetou) 230 : IF (IRetou.NE.0) THEN 230 : IF (IRET.LE.0) CALL ERREUR(36) 231 : IF (IERR.NE.0) RETURN 232 : IOLEC=IRET 232 : CALL GINT2 233 : GOTO 1 234 : ENDIF 234 : CALL MESLIR(-209) 234 : CALL LIRCHA(CHA,1,IRetou) 235 : C On impose IOLEC=3 pour eviter probleme avec lecture terminal 236 : IOLEC=3 236 : CALL GINT2 237 : IUNIT=IOLEC 238 : GOTO 1201 239 : C --------------- 240 : C Option 'ECHO' 241 : C --------------- 242 : 107 IF (ICHOI.EQ.2) THEN 242 : CALL ECRENT(IECHO) 243 : RETURN 244 : ENDIF 244 : CALL MESLIR(-208) 244 : CALL LIRENT(IRET,1,IRetou) 245 : INTERR(1)=iret 245 : IF ((IRET.NE.0).AND.(IRET.NE.1).AND.(IRET.NE.2)) CALL ERREUR(36) 246 : IF (IERR.NE.0) RETURN 247 : IECHO=IRET 248 : GOTO 1 249 : C --------------- 250 : C Option 'ERRE' 251 : C --------------- 252 : 108 IF (ICHOI.EQ.2) THEN 252 : CALL ECRCHA(ERCTRL(IERPER)) 253 : RETURN 254 : ENDIF 254 : CALL MESLIR(-207) 254 : CALL LIRMOT(ERCTRL,NbErre,IRET,1) 255 : IF (IERR.NE.0) RETURN 256 : IERPER=IRET 257 : GOTO 1 258 : C --------------- 259 : C Option 'LECT' 260 : C --------------- 261 : 109 IF (ICHOI.EQ.2) THEN 261 : CALL ECRENT(IOCAR) 262 : RETURN 263 : ENDIF 263 : CALL MESLIR(-206) 263 : CALL LIRENT(IRET,0,IRetou) 264 : IF (IRetou.NE.0) THEN 264 : IF (IRET.LE.0) CALL ERREUR(36) 265 : IF (IERR.NE.0) RETURN 266 : IOCAR=IRET 267 : GOTO 1 268 : ENDIF 268 : CALL MESLIR(-205) 268 : CALL LIRCHA(CHA,1,IRetou) 269 : IUNIT=IOCAR 270 : GOTO 1201 271 : C --------------- 272 : C Option 'DERI' 273 : C --------------- 274 : 110 IF (ICHOI.EQ.2) THEN 274 : CALL ECRCHA(moderi(MEPSIL)) 275 : RETURN 276 : ENDIF 276 : CALL MESLIR(-204) 276 : CALL LIRMOT(MODERI,5,iret,1) 277 : IF (IERR.NE.0) RETURN 278 : MEPSIL=IRET 279 : GO TO 1 280 : C --------------- 281 : C Option 'IMPI' 282 : C --------------- 283 : 111 IF (ICHOI.EQ.2) THEN 283 : CALL ECRENT(IIMPI) 284 : RETURN 285 : ENDIF 285 : CALL MESLIR(-202) 285 : CALL LIRENT(IRET,1,IRetou) 286 : IF (IERR.NE.0) RETURN 287 : IIMPI=IRET 288 : GOTO 1 289 : C --------------- 290 : C Option 'MODE' 291 : C --------------- 292 : 112 IF (ICHOI.EQ.2) THEN 293 : IF (IFOMOD.EQ.-1) THEN 294 : ICHA(1:4)=MFO(4) 295 : ICHA(5:8)=MSFO(ABS(IFOUR)) 295 : CALL ECRCHA(ICHA(1:8)) 296 : ELSE IF (IFOMOD.EQ.3) THEN 297 : ICHA(1:4)=MFO(5) 298 : ICHA(5:8)=OptUnid(1) 299 : ICHA(9:12)=Mode1D(IFOUR-2) 299 : CALL ECRCHA(ICHA(1:12)) 300 : ELSE IF (IFOMOD.EQ.4) THEN 301 : ICHA(1:4)=MFO(5) 302 : ICHA(5:8)=OptUnid(2) 303 : ICHA(9:12)=Mode1D(IFOUR-2) 303 : CALL ECRCHA(ICHA(1:12)) 304 : ELSE IF (IFOMOD.EQ.5) THEN 305 : ICHA(1:4)=MFO(5) 306 : ICHA(5:8)=OptUnid(3) 307 : ICHA(9:12)=' ' 307 : CALL ECRCHA(ICHA(1:8)) 308 : ELSE IF (IFOMOD.EQ.6) THEN 308 : CALL ECRCHA(MFO(6)) 309 : ELSE 309 : CALL ECRCHA(MFO(3-IFOMOD)) 310 : ENDIF 311 : RETURN 312 : ENDIF 312 : CALL MESLIR(-201) 312 : CALL LIRMOT(MFO,NbMfo,IK,1) 313 : IF ((IERR.NE.0).OR.(IK.EQ.0)) RETURN 314 : IF (IK.EQ.1) THEN 315 : IRET=2 316 : ELSE IF (IK.EQ.2) THEN 317 : IRET=1 318 : ELSE IF (IK.EQ.3) THEN 319 : IRET=0 320 : ELSE IF (IK.EQ.4) THEN 321 : IRET=-1 322 : ELSE IF (IK.EQ.5) THEN 323 : IRET=3 324 : ELSE IF (IK.EQ.6) THEN 325 : IRET=6 326 : ENDIF 327 : C Possibilite d'imprimer une erreur si le MODE de calcul n'est pas 328 : C compatible avec la dimension. Debranche pour l'instant. 329 : C** IF ( (IDIM.EQ.2.AND.IRET.NE.-1.AND.IRET.NE.0.AND.IRET.NE.1) 330 : C** . .OR.(IDIM.EQ.1.AND.IRET.NE.3).OR.(IDIM.EQ.3.AND.IRET.NE.2) ) THEN 331 : C** MOTERR(1:4)=MFO(IK) 332 : C** INTERR(1)=IDIM 332 : C** CALL ERREUR(970) 333 : C** RETURN 334 : C** ENDIF 335 : IFOMOD=IRET 336 : if (iret.ne.6) IFOUR=IRET 337 : NIFOUR=0 338 : IF (IRET.EQ.-1) THEN 338 : CALL LIRMOT(MSFO,NbMsfo,IKS,0) 339 : IF (IKS.EQ.0) THEN 340 : IFOUR=-1 341 : ELSE IF (IKS.EQ.1) THEN 342 : IFOUR=-1 343 : ELSE IF (IKS.EQ.2) THEN 344 : IFOUR=-2 345 : ELSE IF (IKS.EQ.3) THEN 346 : IFOUR=-3 347 : ENDIF 348 : ELSE IF (IRET.EQ.1) THEN 348 : CALL LIRENT(NHH,0,ICOND) 349 : IF (ICOND.EQ.0) THEN 349 : CALL LIRMOT(NOHR,NbNoha,NHH,0) 350 : IF (NHH.EQ.1) THEN 351 : READ (NOHR(1),FMT='(A4)') NHH 352 : ELSE 352 : CALL ERREUR(287) 353 : ENDIF 354 : ENDIF 355 : NIFOUR=NHH 356 : ELSE IF (IRET.EQ.3) THEN 356 : CALL LIRMOT(OptUnid,NbUnid,IKS,0) 357 : IF (IKS.EQ.0) THEN 358 : IFOMOD=3 359 : IFOUR=3 360 : ELSE IF (IKS.EQ.1) THEN 361 : IFOMOD=3 361 : CALL LIRMOT(Mode1D(1),9,i,0) 362 : IF (i.EQ.0) i=1 363 : IFOUR=2+i 364 : ELSE IF (IKS.EQ.2) THEN 365 : IFOMOD=4 365 : CALL LIRMOT(Mode1D(10),3,i,0) 366 : IF (i.EQ.0) i=1 367 : IFOUR=11+i 368 : ELSE IF (IKS.EQ.3) THEN 369 : IFOMOD=5 370 : IFOUR=15 371 : ENDIF 372 : ENDIF 373 : GOTO 1 374 : C --------------- 375 : C Option 'CADR' 376 : C --------------- 377 : 113 IF (ICHOI.EQ.2) THEN 378 : XRET=DIOCAD 378 : CALL ECRREE(XRET) 379 : RETURN 380 : ENDIF 380 : CALL MESLIR(-200) 380 : CALL LIRREE(XRET,1,IRetou) 381 : IF (IERR.NE.0) RETURN 382 : DIOCAD=XRET 383 : GOTO 1 384 : C --------------- 385 : C Option 'COUL' 386 : C --------------- 387 : 114 IF (ICHOI.EQ.2) THEN 387 : CALL ECRCHA(NCOUL(IDCOUL)) 388 : RETURN 389 : ENDIF 389 : CALL MESLIR(-199) 389 : CALL LIRMOT(NCOUL(0),NBCOUL,IRET,1) 389 : IF (IRET.LE.0) CALL ERREUR(36) 390 : IF (IERR.NE.0) RETURN 391 : IDCOUL=IRET-1 392 : ICHA=NCOUL(IDCOUL) 393 : GOTO 1 394 : C --------------- 395 : C Option 'NIVE' 396 : C --------------- 397 : 115 IF (ICHOI.EQ.2) THEN 397 : CALL ECRENT(IONIVE) 398 : RETURN 399 : ENDIF 399 : CALL MESLIR(-198) 399 : CALL LIRENT(IRET,1,IRetou) 400 : IF (IERR.NE.0) RETURN 401 : INTERR(1)=IRET 401 : IF ((IRET.LT.18).OR.(IRET.GT.18)) CALL ERREUR(36) 402 : IONIVE=IRET 403 : GOTO 1 404 : C --------------- 405 : C Option 'NGMA' 406 : C --------------- 407 : 116 IF (ICHOI.EQ.2) THEN 407 : CALL ECRENT(NGMAXY) 408 : RETURN 409 : ENDIF 409 : CALL MESLIR(-197) 409 : CALL LIRENT(IRET,1,IRetou) 410 : IF (IERR.NE.0) RETURN 411 : INTERR(1)=IRET 411 : IF (IRET.LT.0) CALL ERREUR (36) 412 : NGMAXY=IRET 413 : GOTO 1 414 : C --------------- 415 : C Option 'SAUV' 416 : C --------------- 417 : 117 IF (ICHOI.EQ.2) THEN 417 : CALL ECRENT(IOSAU) 418 : RETURN 419 : ENDIF 419 : CALL MESLIR(-196) 420 : IFORM=2 421 : IPREFI=0 422 : DIMATT=0.D0 423 : IREFOR=0 424 : ISAFOR=0 424 : IF (IPSAUV.NE.0) CALL LIBPIL(IPSAUV) 425 : IPSAUV=0 425 : 1171 CALL LIRMOT(FORMAT,NbForm,ICHOr,0) 426 : IF (ICHOr.EQ.1) THEN 427 : IFORM=1 428 : ISAFOR=1 429 : GOTO 1171 430 : ELSE IF (ICHOr.EQ.2) THEN 430 : CALL LIRREE(XRET,1,IRetou) 431 : IF (IERR.NE.0) RETURN 432 : DIMFIC=XRET 433 : GOTO 1171 434 : ELSE IF (ICHOr.EQ.3) THEN 435 : IFORM=2 436 : GOTO 1171 437 : ELSE IF (ICHOr.EQ.4) THEN 438 : IFORM=0 439 : GOTO 1171 440 : ENDIF 440 : CALL LIRENT(IRET,0,IRetou) 441 : IF (IRetou.NE.0) THEN 441 : IF (IRET.LE.0) CALL ERREUR(36) 442 : IF (IERR.NE.0) RETURN 443 : IOSAU=IRET 444 : IPSAUV=0 445 : GOTO 1 446 : ENDIF 446 : CALL MESLIR(-195) 446 : CALL LIRCHA(CHA,1,IRetou) 447 : IF (IERR.NE.0) RETURN 448 : NOMFIC=CHA 449 : IUNIT=IOSAU 450 : IPSAUV=0 451 : IF (IFORM.EQ.1) GOTO 3201 452 : IF (IFORM.EQ.2) GOTO 1203 453 : GOTO 1202 454 : C --------------- 455 : C Option 'REST' 456 : C --------------- 457 : 118 CONTINUE 458 : IF (ICHOI.EQ.2) THEN 458 : CALL ECRENT(IORES) 459 : RETURN 460 : ENDIF 461 : IFICLE=0 462 : IFORM=0 463 : IREFOR=0 463 : CALL MESLIR(-193) 463 : 1172 CALL LIRMOT(FORMAT,nbform,ichor,0) 464 : IF (IERR.NE.0) RETURN 465 : IF (ICHOr.EQ.1) THEN 466 : IREFOR=1 467 : IFORM=1 468 : GOTO 1172 469 : ELSE IF (ICHOr.EQ.2) THEN 470 : GOTO 1172 471 : ELSE IF (ICHOr.EQ.3) THEN 472 : IFORM=-2 473 : GOTO 1172 474 : ELSEIF (ICHOr.EQ.4) then 475 : IFORM=0 476 : GOTO 1172 477 : ENDIF 477 : CALL MESLIR(-194) 477 : CALL LIRENT(IRET,0,IRetou) 478 : IF (IRetou.NE.0) THEN 478 : IF (IRET.LE.0) CALL ERREUR(36) 479 : IF (IERR.NE.0) RETURN 480 : IORES=IRET 481 : GOTO 1 482 : ENDIF 482 : CALL LIRCHA(CHA,1,IRetou) 483 : IF (IERR.NE.0) RETURN 484 : IUNIT=IORES 485 : NOMRES=CHA 486 : * test sur le type de fichier 487 : CLOSE(UNIT=IUNIT) 488 : L=LONG(CHA) 489 : IFORM=1 490 : IREFOR=1 491 : IFIOLD=599 492 : OPEN(UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L), 493 : . IOSTAT=IOS,ERR=2000,FORM='FORMATTED') 494 : IF (IOS.EQ.0) THEN 495 : iretou=0 496 : iquoi=0 496 : CALL LFCDES(IORES,IQUOI,IRETOU,IFORM) 497 : * WRITE(IOIMP,*) 'apres lfcdes-1 ',iores,iquoi,iretou,iform 498 : IF (IOS.EQ.0.AND.(IQUOI.GT.0.AND.IQUOI.LT.10).AND. 499 : . IRETOU.EQ.0) THEN 499 : CALL ERREUR(-342) 500 : GOTO 3250 501 : ENDIF 502 : ENDIF 503 : IFORM=0 504 : IREFOR=0 505 : CLOSE(UNIT=IUNIT) 506 : OPEN(UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L), 507 : . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED') 508 : IF (IOS.EQ.0) THEN 509 : iretou=0 510 : iquoi=0 510 : CALL LFCDES (IORES,IQUOI,IRETOU,IFORM) 511 : * WRITE (IOIMP,*) 'apres lfcdes-2 ',iores,iquoi,iretou,iform 512 : IF (IOS.EQ.0.AND.(IQUOI.GT.0.AND.IQUOI.LT.10).AND. 513 : . IRETOU.EQ.0) THEN 513 : CALL ERREUR(-343) 514 : GOTO 3250 515 : ENDIF 516 : ENDIF 517 : IFORM=2 518 : IF (ixdrr.NE.0) IOS=IXDRCLOSE(ixdrr,.TRUE.) 519 : ios=initxdr(CHA(1:L),'r',.TRUE.) 520 : IF (ios.lt.0) GOTO 2000 521 : ixdrr=ios 522 : ios=IXDRSTRING(ixdrr,ICHA(1:10)) 523 : * WRITE(IOIMP,*) ' option rest ',icha(1:10),ios 524 : IF (IOS.GE.0.AND.ICHA(1:10).EQ.'CASTEM XDR') THEN 525 : * WRITE (IOIMP,*) ' on va direct en 1 ' 526 : IFORM=2 527 : iformx=IFORM 527 : CALL ERREUR(-344) 528 : GOTO 1 529 : ENDIF 530 : IFIOLD=424 531 : GOTO 2000 532 : 3250 iformx=IFORM 533 : IF (IFORM.EQ.1) GOTO 2201 534 : IF (IFORM.EQ.-2) GOTO 2203 535 : GOTO 2202 536 : C --------------- 537 : C Option 'ISOV' 538 : C --------------- 539 : 119 IF (ICHOI.EQ.2) THEN 539 : CALL ECRCHA(MISO(ISOTYP+1)) 540 : RETURN 541 : ENDIF 541 : CALL MESLIR(-192) 541 : CALL LIRMOT(MISO,NbIso,IRET,1) 541 : IF (IRET.LE.0) CALL ERREUR(36) 542 : IF (IERR.NE.0) RETURN 543 : ISOTYP=IRET-1 544 : ICHA=MISO(IRET) 545 : GOTO 1 546 : C --------------- 547 : C Option 'OMBRE' 548 : C --------------- 549 : 120 IF (ICHOI.EQ.2) THEN 550 : LOG=.FALSE. 551 : IF (IOMBRE.EQ.1) LOG =.TRUE. 551 : CALL ECRLOG(LOG) 552 : RETURN 553 : ENDIF 553 : CALL MESLIR(-191) 553 : CALL LIRLOG(LOG,1,IRET) 554 : IF (IERR.NE.0) RETURN 555 : IF (LOG) THEN 556 : IOMBRE=1 557 : ELSE 558 : IOMBRE=0 559 : ENDIF 560 : GOTO 1 561 : C --------------- 562 : C Option 'NBP ' 563 : C --------------- 564 : 121 IF (ICHOI.EQ.2) THEN 565 : IRET=XCOOR(/1)/(IDIM+1) 565 : CALL ECRENT(IRET) 566 : RETURN 567 : ENDIF 567 : CALL MESLIR(-190) 567 : CALL LIRENT(IRET,1,IRetou) 568 : IF (IERR.NE.0) RETURN 569 : NBPTS=MAX(0,IRET) 570 : SEGADJ MCOORD 571 : GOTO 1 572 : C --------------- 573 : C Option 'VERI' 574 : C --------------- 575 : 122 IF (ICHOI.EQ.2) THEN 575 : CALL ECRENT(IOSPI) 576 : RETURN 577 : ENDIF 577 : CALL MESLIR(-189) 577 : CALL LIRENT(IRET,1,IRetou) 578 : IF (IERR.NE.0) RETURN 579 : IOSPI=IRET 580 : GOTO 1 581 : C --------------- 582 : C Option 'ZERO' 583 : C --------------- 584 : 123 IF (ICHOI.EQ.2) THEN 584 : CALL ECRENT(IZROSF) 585 : RETURN 586 : ENDIF 586 : CALL MESLIR(-188) 586 : CALL LIRENT(IRET,1,IRetou) 587 : IF (IERR.NE.0) RETURN 588 : IZROSF=MAX(1,IRET) 589 : GOTO 1 590 : C --------------- 591 : C Option 'ACQU' 592 : C --------------- 593 : 124 IF (ICHOI.EQ.2) THEN 593 : CALL ECRENT(IOACQ) 594 : RETURN 595 : ENDIF 595 : CALL MESLIR(-187) 595 : CALL LIRENT(IRET,0,IRetou) 596 : IF (IRetou.NE.0) THEN 597 : IOACQ=IRET 598 : GOTO 1 599 : ENDIF 599 : CALL MESLIR(-186) 599 : CALL LIRCHA(CHA,1,IRetou) 600 : IUNIT=IOACQ 601 : GOTO 1201 602 : C --------------- 603 : C Option '----' 604 : C --------------- 605 : 125 CONTINUE 606 : GOTO 1 607 : C --------------- 608 : C Option 'PLAC' 609 : C --------------- 610 : 126 IF (ICHOI.EQ.2) THEN 610 : CALL ECRENT(IPLLB) 611 : RETURN 612 : ENDIF 612 : CALL MESLIR(-184) 612 : CALL LIRENT(IRET,1,IRetou) 613 : IF (IERR.NE.0) RETURN 614 : C Pourquoi mettre IPLLB en positif ? 615 : C N'etant pas sur de la valeur de IPLTOT il faut pouvoir le mettre 616 : C en negatif tres grand (voir T.C.) 617 : C IRET=MAX(1,IRET) 618 : IPLLB=IRET 619 : GOTO 1 620 : C --------------- 621 : C Option 'LANG' 622 : C --------------- 623 : 127 IF (ICHOI.EQ.2) THEN 623 : CALL ECRCHA (LANGUE) 624 : RETURN 625 : ENDIF 625 : CALL LIRCHA(ICHA,1,IRetou) 626 : IF (IERR.NE.0) RETURN 627 : LANGUE=ICHA 628 : GOTO 1 629 : C --------------- 630 : C Option 'NORM' 631 : C --------------- 632 : 128 IF (ICHOI.EQ.2) THEN 632 : CALL ERREUR(758) 633 : RETURN 634 : ENDIF 635 : C On commence par une remise a plat : tout a 0 . 636 : C On devrait liberer la place occupee eventuellement par ces segments, 637 : C mais comme on a fait SAVSEG avant. Il faudrait aussi les enlever de 638 : C la liste des non-effacables, mais comment ? 639 : NORINC=0 640 : NORVAL=0 641 : NORIND=0 642 : NORVAD=0 643 : C Lecture des mts cles eventuels 643 : CALL LIRMOT(NAUTO,NbAuto,i,0) 644 : IF (i.EQ.2) GOTO 1 645 : C Normalisation automatique 646 : IF (i.EQ.1) THEN 647 : NORINC=-1 648 : GOTO 1 649 : ENDIF 649 : CALL LIROBJ('LISTMOTS',NORINC,1,IRetou) 649 : CALL LIROBJ('LISTREEL',NORVAL,1,IRetou) 650 : IF (IERR.NE.0) THEN 651 : NORINC=0 652 : NORVAL=0 653 : GOTO 1 654 : ENDIF 655 : MLREEL=NORVAL 656 : MLMOTS=NORINC 657 : SEGACT MLREEL,MLMOTS 658 : NRE=PROG(/1) 659 : NMO=MOTS(/2) 660 : SEGDES MLREEL,MLMOTS 661 : IF (NRE.NE.NMO) THEN 661 : CALL ERREUR(212) 662 : NORINC=0 663 : NORVAL=0 664 : RETURN 665 : ENDIF 666 : C Verification s'il n'y a pas de 'LX' la dedans 667 : C La taille de mots doit etre OK si le LISTMOTS est cree par MOTS 668 : SEGACT MLMOTS 669 : DO i=1,NMO 670 : IF (MOTS(i)(1:4).EQ.'LX ') THEN 670 : CALL ERREUR( 759 ) 671 : NORINC=0 672 : NORVAL=0 673 : SEGDES MLMOTS 674 : RETURN 675 : ENDIF 676 : ENDDO 677 : SEGDES MLMOTS 677 : CALL SAVSEG(MLREEL) 677 : CALL SAVSEG(MLMOTS) 677 : CALL LIROBJ('LISTMOTS',NORIND,0,IRetou) 678 : IF (IRetou.EQ.0) GOTO 1 678 : CALL LIROBJ('LISTREEL',NORVAD,1,IRetou) 679 : IF (IERR.NE.0) THEN 680 : NORIND=0 681 : NORVAD=0 682 : ENDIF 683 : MLREEL=NORVAD 684 : MLMOTS=NORIND 685 : SEGACT MLREEL,MLMOTS 686 : NRE=PROG(/1) 687 : NMO=MOTS(/2) 688 : SEGDES MLREEL,MLMOTS 689 : IF (NRE.NE.NMO) THEN 689 : CALL ERREUR(212) 690 : NORIND=0 691 : NORVAD=0 692 : RETURN 693 : ENDIF 693 : CALL SAVSEG(MLREEL) 693 : CALL SAVSEG(MLMOTS) 694 : GOTO 1 695 : C --------------- 696 : C Option 'RESO' 697 : C --------------- 698 : 129 IF (ICHOI.EQ.2) THEN 698 : CALL ECRCHA(MRESOL(NUCROU+1)) 699 : RETURN 700 : ENDIF 700 : CALL MESLIR(-187) 700 : CALL LIRMOT(MRESOL,NbReso,IRetou,1) 701 : IF (IERR.NE.0) RETURN 702 : NUCROU=IRetou-1 703 : GOTO 1 704 : C --------------- 705 : C Option 'FTRA' 706 : C --------------- 707 : 130 IF (iogra.ge.7.and.iogra.le.9) THEN 708 : ZINIPS=.TRUE. 708 : CALL MESLIR(-209) 708 : CALL LIRCHA(CHA,1,IRetou) 709 : IF (IOGRA.EQ.8) THEN 710 : IUPS=97 711 : ELSE 712 : IUPS=24 713 : ENDIF 714 : IUNIT=IUPS 715 : GOTO 1211 716 : ELSE 716 : CALL ERREUR(26) 717 : RETURN 718 : ENDIF 719 : GOTO 1 720 : C --------------- 721 : C Option 'OEIL' 722 : C --------------- 723 : 131 IF (ICHOI.EQ.2) THEN 723 : IF (IOEIL.NE.0) CALL ECROBJ('POINT',IOEIL) 724 : RETURN 725 : ENDIF 725 : CALL LIROBJ('POINT',IOEIL,1,IRetou) 726 : GOTO 1 727 : C --------------- 728 : C Option 'ERMA' 729 : C --------------- 730 : 132 IF (ICHOI.EQ.2) THEN 730 : CALL ECRENT(IERMAX) 731 : ENDIF 732 : GOTO 1 733 : C --------------- 734 : C Option 'ASSI' 735 : C --------------- 736 : 133 IF (ICHOI.EQ.2) THEN 736 : CALL ECRENT(NBESC) 737 : RETURN 738 : ENDIF 738 : IF (NBESC.NE.0) CALL ERREUR(892) 739 : IF (IERR.NE.0) RETURN 739 : CALL LIRENT(IRET,0,IRetou) 740 : IF (IRetou.NE.0) THEN 740 : IF (IRET.LT.0) CALL ERREUR(36) 740 : IF (IRET.GT.512) CALL ERREUR(36) 740 : CALL INIASS(IRET) 741 : NBESC=IRET 742 : ENDIF 743 : GOTO 1 744 : C --------------- 745 : C Option 'EPTR' 746 : C --------------- 747 : 134 IF (ICHOI.EQ.2) THEN 747 : CALL ECRENT(IEPTR) 748 : RETURN 749 : ENDIF 749 : CALL MESLIR(-340) 749 : CALL LIRENT(IRET,1,IRetou) 750 : IF (IRetou.NE.0) THEN 750 : IF (IRET.LT.0) CALL ERREUR(36) 751 : IEPTR=IRET 752 : ENDIF 753 : GOTO 1 754 : C --------------- 755 : C Option 'NAVI' 756 : C --------------- 757 : 135 IF (ICHOI.EQ.2) THEN 757 : CALL ECRCHA(NNAVI(ILNAVI)) 758 : RETURN 759 : ENDIF 759 : CALL MESLIR(-341) 759 : CALL LIRMOT(NNAVI,LNNAVI,IRET,1) 760 : IF (IERR.NE.0) RETURN 760 : IF (IRET.LE.0) CALL ERREUR(36) 761 : ILNAVI=IRET 762 : ICHA=NNAVI(ILNAVI) 763 : GOTO 1 764 : C 765 : C option PARA 766 : C 767 : 136 IF( ICHOI.EQ.2) THEN 768 : if(lupara.eq.1) then 768 : call ecrlog(.TRUE.) 769 : else 769 : call ecrlog (.FALSE.) 770 : endif 771 : RETURN 772 : ELSE 772 : CALL LIRlog(log,1,iretou) 773 : IF (Ierr.NE.0) return 774 : LUPARA=0 775 : if(log) lupara=1 776 : ENDIF 777 : GO TO 1 778 : 137 CONTINUE 778 : CALL LIRENT(msur,1,iretou) 779 : if(ierr.ne.0) return 779 : CALL OOOSUR(MSUR) 780 : GO TO 1 781 : C --------------- 782 : C Option 'POLI' 783 : C --------------- 784 : 138 IF (ICHOI.EQ.2) THEN 784 : CALL ECRCHA(MPOLI(IOPOLI)) 785 : RETURN 786 : ENDIF 786 : CALL MESLIR(-211) 786 : CALL LIRMOT(MPOLI,NbPoli,ij,1) 787 : IF (IERR.NE.0) RETURN 788 : IOPOLI=ij 789 : GOTO 1 790 : C --------------- 791 : C Option 'COSC' 792 : C --------------- 793 : 139 IF (ICHOI.EQ.2) THEN 793 : CALL ECRCHA(MCOSC(ICOSC)) 794 : RETURN 795 : ENDIF 795 : CALL MESLIR(-211) 795 : CALL LIRMOT(MCOSC,NbCosc,ij,1) 796 : IF (IERR.NE.0) RETURN 797 : ICOSC=ij 798 : GOTO 1 799 : C --------------- 800 : C Option 'POTR' 801 : C --------------- 802 : 140 IF (ICHOI.EQ.2) THEN 802 : CALL ECRCHA(MPOTR(IOPOTR)) 803 : RETURN 804 : ENDIF 804 : CALL MESLIR(-211) 804 : CALL LIRMOT(MPOTR,NbPotr,ij,1) 805 : IF (IERR.NE.0) RETURN 806 : IOPOTR=ij 807 : GOTO 1 808 : C ---------------- 809 : C option debug 810 : C ---------------- 811 : 141 IF (ICHOI.EQ.2) THEN 811 : call ecrent (misaup) 812 : return 813 : ENDIF 813 : CALL LIRENT(MISAUP,1,iretou) 814 : IF(IERR.NE.0) RETURN 815 : GO TO 1 816 : C ---------------- 817 : C option 'LOCA' 818 : C ---------------- 819 : 142 IF (ICHOI.EQ.2) THEN 819 : CALL ECRLOG(ZLOPRO) 820 : RETURN 821 : ENDIF 821 : CALL LIRLOG(ZLOPRO,1,IRETOU) 822 : IF (IERR.NE.0) RETURN 823 : GO TO 1 824 : C ----------------- 825 : C Fin des Options 826 : C ----------------- 827 : 828 : C Ouverture de fichier 829 : C ---------------------- 830 : C Option 'SGBD' 831 : 1200 IF (IERR.NE.0) RETURN 832 : CLOSE (UNIT=IUNIT) 833 : L=LONG(CHA) 834 : IFIOLD=424 835 : OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L), 836 : . IOSTAT=IOS,ERR=2000) 837 : IF (IOS.NE.0) GOTO 2000 838 : GOTO 1 839 : C Options 'DONN','LECT','ACQU' 840 : C Verification de l'existence du fichier lors de son ouverture 841 : 1201 IF (IERR.NE.0) RETURN 842 : CLOSE (UNIT=IUNIT) 843 : L=LONG(CHA) 844 : IFIOLD=599 845 : OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L), 846 : . IOSTAT=IOS,ERR=2000,FORM='FORMATTED') 847 : IF (IOS.NE.0) GOTO 2000 848 : GOTO 1 849 : C Options 'IMPR','FTRA','SORT' 850 : 1211 IF (IERR.NE.0) RETURN 851 : CLOSE (UNIT=IUNIT) 852 : L=LONG(CHA) 853 : IFIOLD=424 854 : OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L), 855 : . IOSTAT=IOS,ERR=2000,FORM='FORMATTED') 856 : IF (IOS.NE.0) GOTO 2000 857 : GOTO 1 858 : C Option 'SAUV' 'FORMAT' 859 : 3201 IF (IERR.NE.0) RETURN 860 : CLOSE (UNIT=IUNIT) 861 : if (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. ) 862 : ixdrw=0 863 : iformx=iform 864 : L=LONG(CHA) 865 : IFIOLD=424 866 : OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L), 867 : . IOSTAT=IOS,ERR=2000,FORM='FORMATTED') 868 : IF (IOS.NE.0) GOTO 2000 869 : GOTO 1 870 : C Option 'REST' 'FORMAT' 871 : 2201 IF (IERR.NE.0) RETURN 872 : CLOSE (UNIT=IUNIT) 873 : if (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. ) 874 : ixdrr=0 875 : iformx=iform 876 : L=LONG(CHA) 877 : IFIOLD=599 878 : OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L), 879 : . IOSTAT=IOS,ERR=2000,FORM='FORMATTED') 880 : IF (IOS.NE.0) GOTO 2000 881 : GOTO 1 882 : C Option 'SAUV' 'BINA' (format binaire) 883 : 1202 IF (IERR.NE.0) RETURN 884 : * WRITE(IOIMP,*) ' sauv en binaire' 885 : CLOSE (UNIT=IUNIT) 886 : if (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. ) 887 : iformx=iform 888 : ixdrw=0 889 : L=LONG(CHA) 890 : IFIOLD=424 891 : OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L), 892 : . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED') 893 : IF (IOS.NE.0) GOTO 2000 894 : GOTO 1 895 : C Options 'REST' ('BINA') (format binaire) 896 : 2202 IF (IERR.NE.0) RETURN 897 : * WRITE(IOIMP,*) ' rest en binaire' 898 : CLOSE (UNIT=IUNIT) 899 : if (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. ) 900 : iformx=iform 901 : ixdrr=0 902 : L=LONG(CHA) 903 : IFIOLD=599 904 : OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L), 905 : . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED') 906 : IF (IOS.NE.0) GOTO 2000 907 : GOTO 1 908 : C Options 'SAUV' ('XDR') (format XDR) 909 : 1203 IF (IERR.NE.0) RETURN 910 : IF (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. ) 911 : ixdrw=0 912 : L=LONG(CHA) 913 : IFIOLD=424 914 : IF (iform.GT.0) THEN 915 : ios=initxdr(CHA(1:L),'w',.TRUE.) 916 : if (ios.LT.0) GOTO 2000 917 : ixdrw=ios 918 : ICHA(1:10)='CASTEM XDR' 919 : ios=IXDRSTRING( ixdrw,ICHA(1:10)) 920 : ENDIF 921 : IF (iform.LT.0) THEN 922 : ios=initxdr(CHA(1:L),'r',.TRUE.) 923 : ixdrw=ios 924 : ENDIF 925 : iform=2 926 : iformx=iform 927 : IF (IOS.LT.0) GOTO 2000 928 : GOTO 1 929 : C Options 'REST' (format XDR) 930 : 2203 IF (IERR.NE.0) RETURN 931 : IF (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. ) 932 : ixdrr=0 933 : L=LONG(CHA) 934 : IFIOLD=424 935 : IF (iform.GT.0) THEN 936 : ios=initxdr(CHA(1:L),'w',.TRUE.) 937 : if (ios.LT.0) GOTO 2000 938 : ixdrr=ios 939 : ICHA(1:10)='CASTEM XDR' 940 : ios=IXDRSTRING( ixdrr,ICHA(1:10)) 941 : ENDIF 942 : IF (iform.LT.0) THEN 943 : IFIOLD=599 944 : ios=initxdr(CHA(1:L),'r',.TRUE.) 945 : ixdrr=ios 946 : ENDIF 947 : iform=2 948 : iformx=iform 949 : IF (IOS.LT.0) GOTO 2000 950 : GOTO 1 951 : 952 : C Traitement des erreurs d'ouverture des fichiers 953 : 2000 L=LONG(CHA) 954 : MOTERR=CHA(1:L) 955 : INTERR(1)=IOS 955 : CALL ERREUR(424) 956 : 957 : RETURN 958 : END 959 : 960 : 961 : 962 : 963 : 964 : 965 : 966 : 967 : 968 :
© Cast3M 2003 - All rights reserved.
Disclaimer