C LIPIL SOURCE SP204843 23/02/17 21:15:02 11601 SUBROUTINE LIPIL (ICOLAC,IFIN,IRET,IFORM,LABEL) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C======================================================================= C BUT : LECTURE DU FICHIER FORMATE OU NON IORES DEFINI PAR: C OPTIO REST IORES ; C APPELE PAR : REST C APPELLE : LFCDIM LFCDIE LFCDI2 NOMNST ENSOLF ENTNOM C : LIPOIN LIMAIL ERREUR(12) C ECRIT PAR FARVACQUE -REPRIS PAR LENA C C HISTORIQUE : ajout des objets de type MATRAK et MATRIK par C GOUNAND (15/07/98) C C======================================================================= C TABLEAU KCOLA: VOIR LE SOUS-PROGRAMME TYPFIL C======================================================================= -INC PPARAM -INC CCOPTIO -INC CCNOYAU -INC SMELEME -INC SMBASEM -INC SMCOORD POINTEUR MCOOR1.MCOORD,MCOOR2.MCOORD -INC SMRIGID -INC SMELSTR -INC SMCLSTR -INC SMDEFOR -INC SMSTRUC -INC SMLREEL -INC SMLENTI -INC SMLMOTS -INC SMTEXTE -INC SMTABLE -INC SMSUPER -INC SMVECTD -INC SMCHARG -INC SMEVOLL -INC SMLCHPO -INC SMINTE -INC CCGEOME -INC TMCOLAC -INC CCFXDR -INC CCHAMP -INC SMLOBJE C SEGMENT JPV(MOTS(/2)) C======================================================================= C ICOLAC : KCOLA : POINTEUR SUR LA PILE ITLACC C MCOLA : NOMBRE D'OBJETS INSPECTES DANS LA PILE C ICOLA : POINTEUR SUR ISGTR ( NOM-NOM-RANG DANS ITLACC) C KCOLAC: CONTIENT POUR CHAQUE PILE LE NOMBRE D'OBJETS A C SORTIR C======================================================================= SEGMENT/ITBBE1/( ITABE1(NN)) SEGMENT/ITBBE2/( ITABE2(NN)) segment itbbc2 character*4 itabc2(nn) endsegment SEGMENT/ITBBM1/( ITABM1(NM)) segment itbbc1 character*4 itabc1(nm) endsegment SEGMENT/ITBBM2/( ITABM2(NM2)) segment itbbc3 character*4 itabc3(nm2) endsegment SEGMENT/ITBBM3/( ITABM3(NM2)) segment itbbc4 character*4 itabc4(nm2) endsegment SEGMENT/ITBBM4/( ITABM4(NM2)) segment itbbc5 character*4 itabc5(nm2) endsegment SEGMENT/ITBBR1/( TABR1(L)*D) SEGMENT/NOMM1/(NOM1(NOBJN1)) SEGMENT NOMM2 CHARACTER*(LONOM) NOM2(NOBJN1) ENDSEGMENT SEGMENT ITAMOT CHARACTER*(NN) ITAMO INTEGER ICOTA(NNN) ENDSEGMENT segment xmaaux real*8 reaux(laux,nelrig) endsegment C DIMENSION IPVV(2) DIMENSION ILENA(30) DIMENSION NOMM(2) CHARACTER*(8) ITYPE,CTYPE CHARACTER*72 LABEL REAL*8 XVA LOGICAL LOGI CHARACTER*(72) CHA1T CHARACTER*(LOCHAI) CHA1 CHARACTER*(1) CHARI REAL*4 DENSI4 C-------------------------------------------------------------------- minouv=0 mlnouv=0 mrnouv=0 mmnouv=0 IQUOI =0 NOMM1 =0 NOMM2 =0 ITBBM1=0 ITBBM2=0 ITBBM3=0 ITBBM4=0 ITBBE1=0 ITBBE2=0 ITBBR1=0 IRET =0 IRETOU=0 NOBJN1=0 CHA1T =' ' SEGINI NOMM1,NOMM2 SEGACT ICOLAC*MOD,MCOORD*MOD NBANC =nbpts mianc =minouv mlanc =mlnouv mranc =mrnouv mmanc =mmnouv C ------------------------------------------------------------------ C --- BOUCLE DE LECTURE SUR UN DESCRIPTEUR------------------------- 1097 CONTINUE IRETOU=0 IQUOI =0 CALL LFCDES (IORES,IQUOI,IRETOU,IFORM) IF (IIMPI.EQ.5) WRITE(IOIMP,555) IQUOI,IRETOU 555 FORMAT(' ENREG DE TYPE ',I3,' CODE RETOUR DE LECTURE =',I2) IF(IRETOU.NE.0) THEN IF( IONIVE.GE.10) THEN IF(LABEL.EQ.' '.AND.CHA1T.NE.' ') THEN IRETOU=0 GOTO 1001 ELSE MOTERR(1:24) = LABEL CALL ERREUR (874) GOTO 1000 ENDIF ELSE MOTERR(1:24) = LABEL CALL ERREUR (874) GOTO 1000 ENDIF ENDIF C *** FIN DES LECTURES ********SI IQUOI=5 IF(IQUOI.EQ.5) THEN IF(IONIVE.GE.10) THEN IF(IFORM.EQ.1) READ (IORES,776) CHA1T IF(IFORM.EQ.0) READ (IORES) CHA1T if (iform.eq.2) ios=IXDRSTRING( ixdrr,cha1t(1:72)) 776 FORMAT(A72) WRITE (IOIMP,778) CHA1T 778 FORMAT ( 'FIN DE LECTURE DU LABEL : ',/,A72,/) mianc=minouv mlanc=mlnouv mranc=mrnouv mmanc=mmnouv IF(LABEL.NE.' ') THEN IF(LABEL.EQ.CHA1T ) GOTO 1001 ENDIF GOTO 1097 ENDIF ENDIF GOTO(999 ,5000,4000,444,1001,999 ,4001,4002 ),IQUOI C --- ERREUR 999 GOTO 1000 C-------------------------------------------------------------------- C ***** LECTURE DES INFORMATIONS GENERALES A METTRE DANS LES COMMONS C --- IQUOI=4 444 CONTINUE IF(IFORM.EQ.1)READ(IORES,701,END=1000,ERR=1000) NIVEAU,IARR,JDIM IF(IFORM.EQ.0)READ(IORES, END=1000,ERR=1000) NIVEAU,IARR,JDIM if(IFORM.eq.2) then ios=IXDRINT( ixdrr, niveau ) ios=IXDRINT( ixdrr, iarr ) ios=IXDRINT( ixdrr, jdim ) endif IONIVE=NIVEAU 701 FORMAT(7X,I4,14X,I4,10X,I4) WRITE (IOIMP,33201) NIVEAU 33201 FORMAT (//,' NIVEAU DU FICHIER',I3) IF(NIVEAU .GE. 23)THEN C Lecture de la longueur des Chaines de CARACTERES des composantes ('MCHAML','CHPOINT','LISTMOTS',etc.) C utilisees lors de la sauvegarde IF(IFORM.EQ.1)READ(IORES,700,END=1000,ERR=1000) LCOMLU IF(IFORM.EQ.0)READ(IORES, END=1000,ERR=1000) LCOMLU if(IFORM.eq.2) then ios=IXDRINT( ixdrr, LCOMLU ) endif 700 FORMAT(23X,I4) WRITE (IOIMP,33200) LCOMLU 33200 FORMAT (' TAILLE DES COMPOSANTES',I4) ELSE LCOMLU = -1 ENDIF CCCCC IF (NIVEAU.NE.0) GOTO 1000 IF (IFORM.EQ.1) READ(IORES,702) DENSI4 IF (IFORM.EQ.0) READ(IORES) DENSI4 if (iform.eq.2) ios=IXDRREAL( ixdrr, densi4 ) densit = densi4 702 FORMAT(8X,E12.5) WRITE (IOIMP,201) iarr,JDIM,DENSIT 201 FORMAT (//,' NIVEAU D''ERREUR ',I2,' DIMENSION ',I2,' DENSITE ', 1 1PE12.5) IERMAX=MAX(IERMAX,iarr) * IERR=0 CALLGINT2 IF (IDIM.EQ.0) IDIM=JDIM IF (JDIM.NE.0.AND.JDIM.NE.IDIM) CALL ERREUR(12) GOTO 1097 C C **** Noms des composantes primales et duales ***************** C Repris de la lecture des LISTMOTS C --- IQUOI=8 4002 CONTINUE DO I=1,2 ITOTO=2 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 JGN = ILENA(1) JGM = ILENA(2) * SEGINI MLMOTS NN=JGN*JGM NNN=0 SEGINI ITAMOT CALL LFCDIC(IORES,ITAMO,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 IF (I.EQ.1) THEN LNOMDD=MIN(JGM,1000) KNOMDD=MIN(JGN,LEN(NOMDD(1))) DO IUH = 1,LNOMDD ideb = (IUH-1)*JGN+1 ifin = ideb+knomdd-1 NOMDD(IUH)= ITAMO(ideb:ifin) ENDDO ELSE LNOMDU=MIN(JGM,1000) KNOMDU=MIN(JGN,LEN(NOMDU(1))) DO IUH = 1,LNOMDU ideb = (IUH-1)*JGN+1 ifin = ideb+knomdu-1 NOMDU(IUH)= ITAMO(ideb:ifin) ENDDO ENDIF SEGSUP ITAMOT ENDDO GOTO 1097 C C **** INFORMATIONS GENERALES CASTEM2000 ***************** C --- IQUOI=7 4001 CONTINUE CALL LIINFG (IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 GOTO 1097 C C ***** LECTURE D'UN TITRE ************************************* C --- IQUOI=3 4000 CONTINUE CALL LFCDIM(IORES,18,ILENA,IRETOU,IFORM) WRITE(TITREE,FMT='(18A4)')(ILENA(IY),IY=1,18) IF(IRETOU.NE.0) GOTO 1000 GOTO 1097 C C ***** LECTURE D'UNE PILE ************************************* C --- IQUOI=2 5000 CONTINUE IF(IERR.NE.0) RETURN ITOTO=3 CALL LFCDIP (IORES,ITOTO,ILENA,IRETOU,IFORM) IF ( IRETOU.NE.0) GOTO 1000 IFILE =ILENA(1) NOBJN =ILENA(2) IMAX1 =ILENA(3) ITYPE=' ' IF(IFILE.GT.0) THEN CALL TYPFIL(ITYPE,IFILE) WRITE (IOIMP,805) IMAX1,ITYPE 805 FORMAT( ' LECTURE DE ',I8 , ' OBJETS ',A8) IF(IIMPI.NE.0) * WRITE(IOIMP,803)IFILE,ITYPE,IMAX1,NOBJN ELSE ITYPE='POINT ' IF(IIMPI.NE.0) WRITE(IOIMP,804)IMAX1,NOBJN ENDIF 803 FORMAT(///' * LA FILE NUMERO',I4,' CONSTITUEE D''OBJETS DE TYPE 1 ',A8,' CONTIENT',I8, 1 ' OBJETS, PARMI LESQUELS ',I5,' SONT NOMMES.') 804 FORMAT(///' * IL Y A ',I8,' NOUVEAUX POINTS, PARMI LESQUELS ', 1 I6,' SONT NOMMES.') C --- LECTURE DES NOMS S ILS EXISTENT CALL ENTNOM(IORES,NOBJN,NOMM1,NOMM2,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 C --- LECTURE DE LA PILE - ON EN LIRA IMAX1------------------------- IF(IFILE.LE.0) GOTO 5001 C KCOLAC(IFILE)=IMAX1+ KCOLAC(IFILE) ITLACC=KCOLA(IFILE) C write(6,*) 'IFILE,ITLACC=',IFILE,ITLACC segact itlacc*mod IRETOU=0 C --- GOTO(6001,6002,6003,1002,1002,6006,6007,6008,6009,6010,1002, 1 6012,6013,6014,6015,6016,6017,6018,6019,6020,1002,6022, 1 6023,6024,6025,6026,6027,6028,6029,6030,6031,6032,6033, 1 6034,6035,6036,6037,6038,6039,6040,6041,6042,6043,6010, 1 6045,1098,1098,6048,1098,6050),IFILE 1002 MOTERR(1:8)=ITYPE CALL ERREUR(336) IF (ITYPE.EQ.'ESCLAVE') GOTO 1097 GOTO 1000 C *************** POINTS ET COORD ********************************** 5001 CONTINUE IF(IONIVE.LE.9) THEN CALL LIPOIN (IMAX1,NOBJN,NOMM1,NOMM2,NBANC,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 ENDIF GOTO 1097 C **************************MELEME********************************** 6001 CONTINUE DO 7 IEL=1,IMAX1 IRETOU=0 CALL LIMAIL (MELEME,NBANC,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 ITLAC(**)=MELEME * si on avait avant la restitution un point support de contact il faut l * le confondre avec celui restitue. 7 CONTINUE GOTO 1098 C **************************CHPOINT********************************* 6002 CONTINUE CALL LICHPO(IORES,ITLACC,IMAX1,IRETOU,IFORM,LCOMLU) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C ***********************MRIGID************************************* 6003 CONTINUE NN=0 SEGINI ITBBE1 NM=0 SEGINI ITBBM1,itbbc1 DO 1202 IEL=1,IMAX1 C READ(IORES,8000,END=1000,ERR=1000) NRIGEL,ICHO,NBGEOR,NRIGE,J ITOTO=5 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 NRIGEL= ILENA(1) ICHO = ILENA(2) NBGEOR= ILENA(3) NRIGE = ILENA(4) J = ILENA(5) SEGINI MRIGID ITLAC(**)=MRIGID IFORIG=J C READ(IORES,8001,END=1000,ERR=1000)MTYMAT(1),MTYMAT(2) ITOTO=2 CCC CALL LFCDIM (IORES,ITOTO,MTYMAT,IRETOU,IFORM) if (iform.ne.2) then CALL LFCDIM (IORES,ITOTO,IPVV,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 WRITE(MTYMAT,FMT='(2A4)') IPVV(1),IPVV(2) else ios=IXDRSTRING( ixdrr, mtymat(1:8)) if (ios.lt.0) goto 1000 endif ICHOLE=ICHO NN=NRIGE*NRIGEL+NBGEOR IF(IONIVE.GE.5) NN=NN + NRIGEL SEGADJ ITBBE1 CALL LFCDIE(IORES,NN,ITABE1,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 NNN=0 DO 1203 IR=1,NRIGEL II=NRIGE*(IR-1) DO 1204 NR=1,NRIGE IRR=II+NR IRIGEL(NR,IR)=ITABE1(IRR) 1204 CONTINUE NLIGRP=ITABE1(II+3) NLIGRD=NLIGRP IF(IONIVE.GE.5) THEN NLIGRD=ITABE1(IR+ NRIGE*NRIGEL+NBGEOR) ENDIF NNN=NNN+NLIGRP + NLIGRD SEGINI DESCR IRIGEL(3,IR)=DESCR if(ionive.ge.18.and.ionive.lt.20) then nelrig=ITABE1(II+4) segini xmatri irigel(4,ir)=xmatri endif 1203 CONTINUE IF(NBGEOR.EQ.0) GOTO 1207 SEGINI IMGEOD DO 1206 I=1,NBGEOR IMGEOR(I)=ITABE1(NRIGE*NRIGEL+I) 1206 CONTINUE SEGDES IMGEOD IMGEO1=IMGEOD 1207 NN=NNN IF(IONIVE.LT.5) NN=NN/2 SEGADJ ITBBE1 NM=NNN SEGADJ ITBBM1,itbbc1 CALL LFCDIE(IORES,NN,ITABE1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 if (iform.ne.2) CALL LFCDIM(IORES,NM,ITABM1,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc1(1)(1:nm*4)) IF(IRETOU.NE.0) GOTO 1000 J=0 DO 1208 IR=1,NRIGEL DESCR=IRIGEL(3,IR) SEGACT DESCR*MOD NLIGRP=NOELEP(/1) IF(IONIVE.GE.5) THEN DO 1205 I=1,NLIGRP J=J+1 NOELEP(I)=ITABE1(J) if (iform.ne.2) WRITE(LISINC(I),FMT='(A4)')ITABM1(J) if (iform.eq.2) lisinc(i)=itabc1(j) 1205 CONTINUE NLIGRD=NOELED(/1) DO 1209 I=1,NLIGRD J=J+1 NOELED(I)=ITABE1(J) if (iform.ne.2) WRITE(LISDUA(I),FMT='(A4)')ITABM1(J) if (iform.eq.2) lisdua(i)=itabc1(j) 1209 CONTINUE ELSE DO 1215 I=1,NLIGRP J=J+1 NOELEP(I)=ITABE1(J) NOELED(I)=ITABE1(J) if (iform.ne.2) then WRITE(LISINC(I),FMT='(A4)')ITABM1(2*J-1) else lisinc(i)=itabc1(2*j-1) endif if (iform.ne.2) WRITE(LISDUA(I),FMT='(A4)')ITABM1(2*J) if (iform.eq.2) lisdua(i)=itabc1(2*j) 1215 CONTINUE ENDIF SEGDES DESCR 1208 CONTINUE CALL LFCDI2(IORES,NRIGEL,COERIG,IRETOU,IFORM) if(ionive.ge.18.and.ionive.lt.20) then do ir=1,nrigel xmatri=irigel(4,ir) lval=re(/1)*re(/2)*re(/3) call lfcdi2(iores,lval,re,iretou,iform) segdes xmatri enddo endif SEGDES MRIGID IF(IRETOU.NE.0) GOTO 1000 1202 CONTINUE SEGSUP ITBBM1,itbbc1,ITBBE1 GOTO 1098 C *************************** ******************************* 6004 CONTINUE GOTO 1098 C *********************** ********************************* 6005 CONTINUE GOTO 1098 C ********************************BLOQ STRUC 6006 CONTINUE DO 60 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 N=ILENA(1) SEGINI MCLSTR ITLAC(**)= MCLSTR CALL LFCDIE (IORES,N ,ISOSTR,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 CALL LFCDIE (IORES,N ,IRIGCL,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 SEGDES MCLSTR 60 CONTINUE GOTO 1098 C ********************************ELEM STRUC 6007 CONTINUE DO 70 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 N=ILENA(1) SEGINI MELSTR ITLAC(**) =MELSTR CALL LFCDIE (IORES,N ,ISOSTU,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 CALL LFCDIE (IORES,N ,IMELEM,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 SEGDES MELSTR 70 CONTINUE GOTO 1098 C ****************************MSOLUT******************************** 6008 CONTINUE IMAX2=IMAX1 DO 1800 IEL=1,IMAX1 IRETOU=0 IF (NIVEAU.LE.2) CALL ENSOLF(ICOLAC,IRET,IFORM) IF (NIVEAU.LE.2) MSOLUT=IRET IF (NIVEAU.GE.3) CALL LISOLU(MSOLUT,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 IRET=MSOLUT IF(IRET.GE.0) THEN ITLAC(**)=IRET ELSE IF(IRET.LT.0) THEN ITLAC(**)=-IRET IMAX2=IEL ELSE IMAX2=IEL-1 ENDIF GOTO 1801 ENDIF 1800 CONTINUE 1801 CONTINUE IMAX1=IMAX2 GOTO 1098 C ***************************MSTRUC******************************** 6009 CONTINUE DO 1901 IEL=1,IMAX1 C READ(IORES,8000,END=1000,ERR=1000) N ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) SEGINI MSTRUC ITLAC(**)=MSTRUC CALL LFCDIE(IORES,N,LISTRU,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 SEGDES MSTRUC 1901 CONTINUE GOTO 1098 C ******************************* MTABLE ************************** 6010 CONTINUE NN=0 SEGINI ITBBE1 ITOTO=1 DO 710 IEL=1,IMAX1 MTABLE=0 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) * write (6,*) ' lipil table ',ilena(1) IF (IRETOU.NE.0) GOTO 1000 NN=ILENA(1) CCC IF (NN.EQ.0) GOTO 109 M=NN/4 SEGINI MTABLE MLOTAB=M IF (NN.EQ.0) GOTO 713 SEGADJ ITBBE1 CALL LFCDIE (IORES,NN,ITABE1,IRETOU,IFORM) * write (6,*) ' lipil table ',(itabe1(ii),ii=1,nn) IF(IRETOU.NE.0) GOTO 1000 KK=0 DO 711 K=1,NN,4 KK=KK+1 J=ITABE1(K) IVA=ITABE1(K+1) CTYPE=' ' CALL TYPFIL (CTYPE,J) if (ctype.eq.'ENTIER') then * write (6,*) ' lipil indice table ',ctype,iva,mianc if (ionive.le.20) iva=iva+mianc endif if (ctype.eq.'FLOTTANT') then * write (6,*) ' lipil indice table ',ctype,iva,mranc iva=iva+mranc if (iva.eq.0) call erreur(5) endif if (ctype.eq.'LOGIQUE') then iva=iva+mlanc if (iva.eq.0) call erreur(5) endif if (ctype.eq.'MOT ') then iva=iva+mmanc if (iva.eq.0) call erreur(5) endif MTABII(KK)=IVA MTABTI(KK)=CTYPE J=ITABE1(K+2) IVA=ITABE1(K+3) CTYPE=' ' CALL TYPFIL (CTYPE,J) if (ctype.eq.'ENTIER') then * write (6,*) ' lipil valeur table ',ctype,iva,mianc if (ionive.le.20) iva=iva+mianc endif if (ctype.eq.'FLOTTANT') then * write (6,*) ' lipil indice table ',ctype,iva,mranc iva=iva+mranc if (iva.eq.0) call erreur(5) endif if (ctype.eq.'LOGIQUE') then iva=iva+mlanc if (iva.eq.0) call erreur(5) endif if (ctype.eq.'MOT ') then iva=iva+mmanc if (iva.eq.0) call erreur(5) endif ** en attendant de savoir lire un esclave IF (CTYPE.EQ.'ESCLAVE') CTYPE='ANNULE' MTABIV(KK)=IVA MTABTV(KK)=CTYPE 711 CONTINUE 713 SEGDES MTABLE 109 ITLAC(**)=MTABLE 710 CONTINUE SEGSUP ITBBE1 GOTO 1098 C ***************************** ***************************** 6011 CONTINUE GOTO 1098 C **********************&**MSOSTU******************************* 6012 CONTINUE NN=0 SEGINI ITBBE1 DO 2201 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 NS = ILENA(1) SEGINI MSOSTU ITLAC (**)=MSOSTU C READ(IORES,8000,END=1000,ERR=1000)ITYSOU,ISRAID,ISMASS ITOTO=3+NS NN=ITOTO SEGADJ ITBBE1 CALL LFCDIE (IORES,ITOTO,ITABE1(1),IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 ITYSOU= ITABE1(1) ISRAID= ITABE1(2) ISMASS= ITABE1(3) IF (NS.EQ.0) GOTO 120 DO 12 I=1,NS ISCHAM(I)= ITABE1(I+3) 12 CONTINUE 120 SEGDES MSOSTU 2201 CONTINUE SEGSUP ITBBE1 GOTO 1098 C ***************************** IMATRI ***************************** 6013 CONTINUE DO 2300 IEL=1,IMAX1 C READ(IORES,8000,END=1000,ERR=1000)NELRIG ITOTO=4 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 nelrig=ilena(3) nligrd=ilena(1) nligrp=ilena(2) lval=nelrig*nligrp*nligrd segini xmatri symre=ilena(4) if (symre.eq.0.and.nligrp.eq.nligrd) then * cas symetrique on ne lit que la partie triangulaire laux=nligrp*(nligrp+1)/2 segini xmaaux call lfcdi2(iores,laux*nelrig,reaux, > iretou,iform) do k=1,nelrig ip=0 do j=1,nligrp do i=1,j re(i,j,k)=reaux(ip+i,k) re(j,i,k)=reaux(ip+i,k) enddo ip=ip+j enddo enddo segsup xmaaux else * cas general on lit tout call lfcdi2(iores,lval,re,iretou,iform) endif itlac(**)=xmatri SEGDES xMATRI 2300 CONTINUE GOTO 1098 C ***************************** MJONCT ***************************** 6014 CONTINUE CALL LIJONC (IORES,ITLACC,IMAX1,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C ***************************** MATTAC ***************************** 6015 CONTINUE CALL LIATTA (IORES,ITLACC,IMAX1,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C ***************************** MMATRI ***************************** 6016 CONTINUE CALL LIMMAT (IORES,ITLACC,IMAX1,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C *************************MDEFOR******************************* 6017 CONTINUE NN=0 SEGINI ITBBE1 DO 2700 IEL=1,IMAX1 C READ(IORES,8000,END=1000,ERR=1000) NDEF ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 NDEF = ILENA(1) SEGINI MDEFOR ITLAC(**)=MDEFOR CALL LFCDI2(IORES,NDEF,AMPL,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 C READ(IORES,8000,END=1000,ERR=1000)(IELDEF(I),I=1,NDEF),(ICHDEF(I), C 1 I=1,NDEF), (JCOUL(I),I=1,NDEF) NN=7*NDEF SEGADJ ITBBE1 CALL LFCDIE (IORES,NN,ITABE1,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 CALL JDANSI ( IELDEF(1),ITABE1(1),NDEF) CALL JDANSI ( ICHDEF(1),ITABE1(NDEF +1),NDEF) CALL JDANSI ( JCOUL(1),ITABE1(2*NDEF+1),NDEF) CALL JDANSI ( MTVECT(1),ITABE1(3*NDEF+1),NDEF) CALL JDANSI ( MDCHP(1),ITABE1(4*NDEF+1),NDEF) CALL JDANSI ( MDCHEL(1),ITABE1(5*NDEF+1),NDEF) CALL JDANSI ( MDMODE(1),ITABE1(6*NDEF+1),NDEF) SEGDES MDEFOR 2700 CONTINUE SEGSUP ITBBE1 GOTO 1098 C ******************************MLREEL************************** 6018 CONTINUE DO 2800 IEL=1,IMAX1 C READ(IORES,8000,END=1000,ERR=1000)N ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) JG=N SEGINI MLREEL CALL LFCDI2(IORES,N,PROG,IRETOU,IFORM) SEGDES MLREEL IF(IRETOU.NE.0) GOTO 1000 ITLAC(**)=MLREEL 2800 CONTINUE GOTO 1098 C ******************************MLENTI**************************** 6019 CONTINUE DO 2900 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) JG=N SEGINI MLENTI CALL LFCDEE(IORES,N,LECT,IRETOU,IFORM) SEGDES MLENTI IF(IRETOU.NE.0) GOTO 1000 ITLAC(**)=MLENTI 2900 CONTINUE GOTO 1098 C ****************************MCHARG****************************** 6020 CONTINUE NN=0 NM=0 NM2=0 SEGINI ITBBM1,itbbc1 SEGINI ITBBM2,itbbc3 SEGINI ITBBM3,itbbc4 SEGINI ITBBM4,itbbc5 SEGINI ITBBE1 SEGINI ITBBE2,itbbc2 DO 3000 IEL=1,IMAX1 C READ(IORES,8000,END=1000,ERR=1000)N IF(IONIVE.LE.6) THEN ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) SEGINI MCHARG NM=2*N SEGADJ ITBBM1,itbbc1 if (iform.ne.2) CALL LFCDIM(IORES,NM,ITABM1,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc1(1)(1:nm*4)) IF(IRETOU.NE.0) GOTO 1000 NN=3*N SEGADJ ITBBE1 CALL LFCDIE(IORES,NN,ITABE1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 3001 I=1,N c WRITE (CHANOM(I),FMT='(I4)') I CHANOM(I)=' ' SEGINI ICHARG KCHARG(I)=ICHARG I2=2*I I3=3*I if (iform.ne.2) then WRITE (CHANAT(I),FMT='(2A4)') ITABM1(I2-1),ITABM1(I2) else chanat(i)(1:4)=itabc1(i2-1) chanat(i)(5:8)=itabc1(i2) endif CHATYP='CHPOINT ' ICHPO1=ITABE1(I3-2) ICHPO2=ITABE1(I3-1) ICHPO3=ITABE1(I3) SEGDES ICHARG 3001 CONTINUE ELSE IF (IONIVE.GE.7.AND.IONIVE.LE.10) THEN ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) SEGINI MCHARG NN=2*N SEGADJ ITBBE2,itbbc2 if (iform.ne.2) CALL LFCDIM(IORES,NN,ITABE2,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc2(1)(1:nn*4)) IF(IRETOU.NE.0) GOTO 1000 NM2=N SEGADJ ITBBM2,itbbc3 if (iform.ne.2) CALL LFCDIM(IORES,NM2,ITABM2,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc3(1)(1:nm2*4)) IF(IRETOU.NE.0) GOTO 1000 NM=2*N SEGADJ ITBBM1,itbbc1 if (iform.ne.2) CALL LFCDIM(IORES,NM,ITABM1,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc1(1)(1:nm*4)) IF(IRETOU.NE.0) GOTO 1000 NN=3*N SEGADJ ITBBE1 CALL LFCDIE(IORES,NN,ITABE1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 3002 I=1,N SEGINI ICHARG KCHARG(I)=ICHARG I2=2*I I3=3*I if (iform.ne.2) then WRITE (CHATYP,FMT='(2A4)') ITABM1(I2-1),ITABM1(I2) WRITE (CHANAT(I),FMT='(2A4)') ITABE2(I2-1),ITABE2(I2) WRITE (CHANOM(I),FMT='(1A4)') ITABM2(I) else chatyp(1:4)=itabc1(i2-1) chatyp(5:8)=itabc1(i2) chanat(i)(1:4)=itabc2(i2-1) chanat(i)(5:8)=itabc2(i2) chanom(i)=itabc3(i) endif c initialise par defaut CHAMOB(I) = 'STAT' CHALIE(I) = 'LIE ' c.. ICHPO1=ITABE1(I3-2) ICHPO2=ITABE1(I3-1) ICHPO3=ITABE1(I3) SEGDES ICHARG 3002 CONTINUE ELSE ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) SEGINI MCHARG NN=2*N SEGADJ ITBBE2,itbbc2 if (iform.ne.2) CALL LFCDIM(IORES,NN,ITABE2,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc2(1)(1:nn*4)) IF(IRETOU.NE.0) GOTO 1000 NM2=N SEGADJ ITBBM2,itbbc3 if (iform.ne.2) CALL LFCDIM(IORES,NM2,ITABM2,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc3(1)(1:nm2*4)) IF(IRETOU.NE.0) GOTO 1000 SEGADJ ITBBM3,itbbc4 if (iform.ne.2) CALL LFCDIM(IORES,NM2,ITABM3,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc4(1)(1:nm2*4)) IF(IRETOU.NE.0) GOTO 1000 SEGADJ ITBBM4,itbbc5 if (iform.ne.2) CALL LFCDIM(IORES,NM2,ITABM4,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc5(1)(1:nm2*4)) IF(IRETOU.NE.0) GOTO 1000 NM=2*N SEGADJ ITBBM1,itbbc1 if (iform.ne.2) CALL LFCDIM(IORES,NM,ITABM1,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc1(1)(1:nm*4)) IF(IRETOU.NE.0) GOTO 1000 NN=7*N SEGADJ ITBBE1 CALL LFCDIE(IORES,NN,ITABE1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 3003 I=1,N SEGINI ICHARG KCHARG(I)=ICHARG I2=2*I I3=7*I if (iform.ne.2) then WRITE (CHATYP,FMT='(2A4)') ITABM1(I2-1),ITABM1(I2) WRITE (CHANAT(I),FMT='(2A4)') ITABE2(I2-1),ITABE2(I2) WRITE (CHANOM(I),FMT='(1A4)') ITABM2(I) WRITE (CHAMOB(I),FMT='(1A4)') ITABM3(I) WRITE (CHALIE(I),FMT='(1A4)') ITABM4(I) else chatyp(1:4)=itabc1(i2-1) chatyp(5:8)=itabc1(i2) chanat(i)(1:4)=itabc2(i2-1) chanat(i)(5:8)=itabc2(i2) chanom(i)=itabc3(i) chamob(i)=itabc4(i) chalie(i)=itabc5(i) endif ICHPO1=ITABE1(I3-6) ICHPO2=ITABE1(I3-5) ICHPO3=ITABE1(I3-4) ICHPO4=ITABE1(I3-3) ICHPO5=ITABE1(I3-2) ICHPO6=ITABE1(I3-1) ICHPO7=ITABE1(I3) if (ionive.le.19) then ** if (ICHPO4.gt.0) then if (chamob(i).eq.'TRAN') then ipt1 = ICHPO4 + nbanc CALL CRELEM(ipt1) C*? C On verifie s'il n'a pas deja ete preconditionne. C*? CALL CRECH1(ipt1,1) segdes,ipt1 ICHPO4 = ipt1 else if (chamob(i).eq.'ROTA') then ipt1 = ICHPO4 + nbanc CALL CRELEM(ipt1) C*? C On verifie s'il n'a pas deja ete preconditionne. C*? CALL CRECH1(ipt1,1) segdes,ipt1 ICHPO4 = ipt1 if (ICHPO5.gt.0) then ipt1 = ICHPO5 + nbanc CALL CRELEM(ipt1) C*? C On verifie s'il n'a pas deja ete preconditionne. C*? CALL CRECH1(ipt1,1) segdes,ipt1 ICHPO5 = ipt1 endif endif ** endif endif SEGDES ICHARG 3003 CONTINUE ENDIF SEGDES MCHARG ITLAC(**)=MCHARG 3000 CONTINUE SEGSUP ITBBM1,itbbc1,ITBBE1,ITBBM2,itbbc3,ITBBM3,itbbc4, > ITBBM4,itbbc5,ITBBE2,itbbc2 GOTO 1098 C **************************** ************************** 6021 CONTINUE GOTO 1098 C *****************************MEVOLL*************************** 6022 CONTINUE NN=0 NM=0 NM2=20 SEGINI ITBBM2,itbbc3 SEGINI ITBBE1,ITBBM1,itbbc1 LDECA=7 IF(NIVEAU.GE.3) LDECA=11 LDECA2=18 DO 3200 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) NM2=20 SEGADJ ITBBM2,itbbc3 SEGINI MEVOLL if (iform.ne.2) then CALL LFCDIM(IORES,NM2,ITABM2,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 WRITE (ITYEVO,FMT='(2A4)') ITABM2(1),ITABM2(2) WRITE(IEVTEX,FMT='(18A4)') (ITABM2(I+2),I=1,18) else ios=IXDRSTRING( ixdrr, itabc3(1)(1:nm2*4)) * write (6,*) ' evol itabc3 ',itabc3(1),itabc3(2) ityevo(1:4)=itabc3(1) ityevo(5:8)=itabc3(2) do jpv=1,18 ievtex(1+4*(jpv-1):4*jpv)=itabc3(jpv+2) enddo endif NN=3*N SEGADJ ITBBE1 CALL LFCDIE(IORES,NN,ITABE1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 NM=LDECA*N SEGADJ ITBBM1,itbbc1 if (iform.ne.2) CALL LFCDIM(IORES,NM,ITABM1,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc1(1)(1:nm*4)) IF(IRETOU.NE.0) GOTO 1000 IF (NIVEAU.LT.3) GOTO 221 NM2=LDECA2*N SEGADJ ITBBM2,itbbc3 if (iform.ne.2) CALL LFCDIM(IORES,NM2,ITABM2,IRETOU,IFORM) if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc3(1)(1:nm2*4)) IF(IRETOU.NE.0) GOTO 1000 221 CONTINUE DO 3201 IN=1,N SEGINI KEVOLL IEVOLL(IN)=KEVOLL I4=3*IN IPROGX=ITABE1(I4-2) IPROGY=ITABE1(I4-1) NUMEVX=ITABE1(I4) I7=LDECA*(IN-1) if (iform.ne.2) then WRITE(NOMEVX,FMT='(3A4)')(ITABM1(I7+I),I=1,3) WRITE(NOMEVY,FMT='(3A4)')(ITABM1(I7+I+3),I=1,3) WRITE (NUMEVY,FMT='(A4)') ITABM1(I7+7) IF(NIVEAU.GE.3) THEN I8=LDECA2*(IN-1) WRITE(TYPX,FMT='(2A4)')(ITABM1(I7+7+I),I=1,2) WRITE(TYPY,FMT='(2A4)')(ITABM1(I7+9+I),I=1,2) WRITE(KEVTEX,FMT='(18A4)') (ITABM2(I8+JPV),JPV=1,18) ENDIF else * write (6,*) ' evol itabc1 ',itabc1(i7+1),itabc1(i7+2) * write (6,*) ' evol itabc1 ',itabc1(i7+3+1),itabc1(i7+3+2) nomevx(1:4)=itabc1(i7+1) nomevx(5:8)=itabc1(i7+2) nomevx(9:12)=itabc1(i7+3) nomevy(1:4)=itabc1(i7+3+1) nomevy(5:8)=itabc1(i7+3+2) nomevy(9:12)=itabc1(i7+3+3) numevy=itabc1(i7+7) if (niveau.ge.3) then I8=LDECA2*(IN-1) typx(1:4)=itabc1(i7+7+1) typx(5:8)=itabc1(i7+7+2) typy(1:4)=itabc1(i7+9+1) typy(5:8)=itabc1(i7+9+2) do jpv=1,18 kevtex(1+(jpv-1)*4:4*jpv)=itabc3(i8+jpv) enddo endif endif 3202 CONTINUE SEGDES KEVOLL 3201 CONTINUE SEGDES MEVOLL ITLAC(**)=MEVOLL 3200 CONTINUE SEGSUP ITBBE1,ITBBM1,itbbc1 SEGSUP ITBBM2,itbbc3 GOTO 1098 C C **********************SUPERELE************************************ 6023 CONTINUE ITOTO=1 DO 230 IEL=1,IMAX1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 NTOTO=ILENA(1) SEGINI MSUPER ITLAC(**)=MSUPER CALL LFCDIE (IORES,NTOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1023 MRIGTO=ILENA(1) MSUPEL=ILENA(2) MSURAI=ILENA(3) MBLOQU=ILENA(4) MSUMAS=ILENA(5) MCROUT=ILENA(6) SEGDES MSUPER 230 CONTINUE GOTO 1098 1023 CONTINUE SEGDES MSUPER GOTO 1000 C ************************* LOGIQUE *************************** 6024 CONTINUE ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) M=ITLAC(/1) do i=m+1,m+n itlac(**)=0 enddo CALL LFCDIE (IORES,N,ITLAC(M+1),IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 242 I=m+1,m+n ITOTO=ITLAC(I) LOGI=.FALSE. IF(ITOTO.EQ.1)LOGI=.TRUE. CALL QUERAN (IRAT,'LOGIQUE ',IVB,XVA,CTYPE,LOGI,IOB) ITLAC(i) =IRAT 242 CONTINUE mlnouv=itlac(/1) GOTO 1098 C ******************************FLOTTANT********************** 6025 CONTINUE ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) M=ITLAC(/1) L=N SEGINI ITBBR1 CALL LFCDI2(IORES,N,TABR1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 250 I=1,N XVA=TABR1(I) CALL QUERAN(IRAT,'FLOTTANT',IVB,XVA,CTYPE,LOGI,IOB) ITLAC(**)=IRAT 250 CONTINUE SEGSUP ITBBR1 ITBBR1=0 mrnouv=itlac(/1) GOTO 1098 C **************************** ENTIER*************************** 6026 CONTINUE ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) M=ITLAC(/1) L=N NN=L SEGINI ITBBE1 CALL LFCDEE(IORES,N,ITABE1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 260 I=1,L IVB=ITABE1(I) itlac(**)=ivb 260 CONTINUE SEGSUP ITBBE1 minouv=itlac(/1) GOTO 1098 C **************************** MOT *************************** 6027 CONTINUE ITOTO=2 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(2) NNN=N NN=ILENA(1) SEGINI ITAMOT MM=ITLAC(/1)+1 DO 271 I=1,N ITLAC(**)=0 271 CONTINUE CALL LFCDIC(IORES,ITAMO,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 CALL LFCDIE(IORES,N,ICOTA,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 M=1 DO 270 I=1,N LL=ICOTA(I) NN=ICOTA(I)-M+1 IVA=NN CHA1(1:NN)=ITAMO(M:LL) M=LL+1 CALL QUERAN(IRAT,'MOT ',IVA,XVA,CHA1(1:NN),LOGI,IOB) if (irat.eq.0) call erreur(5) ITLAC(MM+I-1) =IRAT 270 CONTINUE SEGSUP ITAMOT mmnouv=itlac(/1) GOTO 1098 C ****************************TEXTE ************************* 6028 CONTINUE DO 280 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) SEGINI MTEXTE NCART= N CALL LFCDIC(IORES,MTEXT,IRETOU,IFORM) SEGDES MTEXTE IF(IRETOU.NE.0) GOTO 1000 ITLAC(**)=MTEXTE 280 CONTINUE GOTO 1098 C ******************************MLMOTS**************************** 6029 CONTINUE DO 290 IEL=1,IMAX1 ITOTO=2 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 JGN = ILENA(1) JGM = ILENA(2) SEGINI MLMOTS NN=JGN*JGM NNN=0 SEGINI ITAMOT CALL LFCDIC(IORES,ITAMO,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 56 IUH = 1,JGM MOTS(IUH)= ITAMO((IUH-1)*JGN+1:IUH*JGN) 56 CONTINUE SEGSUP ITAMOT SEGDES MLMOTS ITLAC(**)=MLMOTS 290 CONTINUE GOTO 1098 C **************************MVECTE********************************** 6030 CONTINUE DO 300 IOB=1,IMAX1 IRETOU=0 CALL LIVECT (MVECTE,IORES,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 ITLAC(**)=MVECTE 300 CONTINUE GOTO 1098 C ************************* VECTD *************************** 6031 CONTINUE DO 310 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 INC = ILENA(1) SEGINI MVECTD CALL LFCDI2(IORES,N,VECTBB,IRETOU,IFORM) SEGDES MVECTD IF(IRETOU.NE.0) GOTO 1000 ITLAC(**)=MVECTD 310 CONTINUE GOTO 1098 C **************************** POINTS ************************** 6032 CONTINUE ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N = ILENA(1) M = ITLAC(/1) IPLU=N-M DO 322 I=1,IPLU ITLAC(**)=0 322 CONTINUE CALL LFCDIE(IORES,N,ITLAC,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 321 I=1,N ITLAC(I)=ITLAC(I)+NBANC 321 CONTINUE GOTO 1098 C ****************************CONFIG ************************* 6033 CONTINUE IAV=ITLAC(/1) * write(6,*) ' imax1 iav ' , imax1,iav iconul=0 ibon=0 DO 330 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) * write(6,*) ' lipil iel ilena(1)' , iel , ilena(1) IF (IRETOU.NE.0) GOTO 1000 ILONG=ILENA(1) * write(6,*) ' lipil iel ilong' , iel , ilong if(ilong.eq.0) then iconul=iconul+1 * nbpts=idim+1 * segini mcoor1 * itlac(**)=mcoor1 GOTO 330 endif IDRES=IDIM IDIM = 0 * write(6,*) ' iel ilong idres nbanc ', iel,ilong,idres,nbanc NBPTS = ILONG+NBANC*(IDRES+1) SEGINI MCOOR1 if(ibon.eq.0) ibon=mcoor1 IDIM=IDRES IDIM11= (IDIM+1)*NBANC+1 CALL LFCDI2(IORES,ILONG,MCOOR1.XCOOR(IDIM11),IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 DO 332 J=1,NBANC*(IDIM+1) MCOOR1.XCOOR(J)=XCOOR(J) 332 CONTINUE * write(6,*) ' mcoor1' , mcoor1 SEGDES MCOOR1 ITLAC(**)=MCOOR1 330 CONTINUE IF(IONIVE.GT.9) THEN if( iconul.ne.imax1) then MCOOR1=Ibon SEGACT MCOOR1*MOD SEGDES MCOORD MCOORD=MCOOR1 nbpts=xcoor(/1)/(idim+1) * write(6,*) ' mcoord ' , mcoord endif ENDIF GOTO 1098 C *************************** MLCHPO ************************* 6034 CONTINUE DO 340 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N1 = ILENA(1) SEGINI MLCHPO ITLAC(**)=MLCHPO CALL LFCDIE(IORES,N1,ICHPOI,IRETOU,IFORM) SEGDES MLCHPO IF(IRETOU.NE.0) GOTO 1000 340 CONTINUE GOTO 1098 C ****************************MBASEM***************************** 6035 CONTINUE NN=0 DO 3500 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE( IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 N=ILENA(1) SEGINI MBASEM DO 3501 I=1,N ITOTO=1 CALL LFCDIE( IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 NIBST=ILENA(1) SEGINI MSOBAS LISBAS(I)=MSOBAS CALL LFCDIE(IORES,NIBST,IBSTRM(1),IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 SEGDES MSOBAS 3501 CONTINUE SEGDES MBASEM ITLAC(**)=MBASEM 3500 CONTINUE GOTO 1098 C *************************** PROCED **************************** 6036 CONTINUE c ========= LES PROCEDURES NE SONT PAS SAUVEES ========= c IMAX1=NOBJN c SEGACT NOMM1,NOMM2 c DO 636 IEL=1,IMAX1 c SEGACT NOMM1,NOMM2 c CHA1(1:8)=NOM2(IEL) c CHA1(9:16)=' ' c CALL CQUOI(CHA1(1:8),CHA1(9:16),IVAL,XVA,CHARI,LOGI,IOBJ) c IF(IERR.EQ.0)THEN c ITLAC(**)= IOBJ c ELSE c IRETOU=1 c GOTO 1000 c ENDIF c 636 CONTINUE GOTO 1097 C *************************** BLOC **************************** 6037 CONTINUE GOTO 1097 C *************************** MMODEL **************************** 6038 CONTINUE CALL LIMODL(IORES,ITLACC,IMAX1,IRETOU,IFORM,NIVEAU,NBANC) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C *************************** MCHAML **************************** 6039 CONTINUE CALL LICHAM(IORES,ITLACC,IMAX1,IRETOU,IFORM,NIVEAU) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C *************************** MINTE **************************** 6040 CONTINUE DO 2840 IEL=1,IMAX1 ITOTO=2 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 NBNO = ILENA(1) NBPGAU = ILENA(2) L=NBPGAU*4+6*NBPGAU*NBNO SEGINI ITBBR1 CALL LFCDI2 (IORES,L,TABR1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 SEGINI MINTE I=0 DO 2841 IC=1,NBPGAU I=I+1 POIGAU(IC)=TABR1(I) I=I+1 QSIGAU(IC)=TABR1(I) I=I+1 ETAGAU(IC)=TABR1(I) I=I+1 DZEGAU(IC)=TABR1(I) DO 28411 IB=1,NBNO DO 28412 IA=1,6 I=I+1 SHPTOT(IA,IB,IC)=TABR1(I) 28412 CONTINUE 28411 CONTINUE 2841 CONTINUE SEGSUP ITBBR1 SEGDES MINTE ITLAC(**)=MINTE 2840 CONTINUE GOTO 1098 C **************************NUAGE *************************** 6041 CALL LINUAG(IORES,ITLACC,IMAX1,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 GOTO 1098 C ************************* MATRAK ******************************** 6042 CONTINUE CALL LIMTAK(IORES,ITLACC,IMAX1,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C ************************* MATRIK ******************************** 6043 CONTINUE CALL LIMTIK(IORES,ITLACC,IMAX1,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C ************************** METHODE ***************************** 6045 CONTINUE DO 6945 I=1,IMAX1 ITLAC(**)=0 6945 CONTINUE CALL LFCDIE(IORES,1,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 CALL LFCDIE(IORES,IMAX1,ITLAC,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C ************************* IELVAL ******************************** 6048 CONTINUE CALL LIIELV(IORES,ITLACC,IMAX1,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 GOTO 1098 C ************************ LISTOBJE ******************************* 6050 CONTINUE DO 500 IEL=1,IMAX1 ITOTO=1 CALL LFCDIE (IORES,ITOTO,ILENA,IRETOU,IFORM) IF (IRETOU.NE.0) GOTO 1000 NOBJ = ILENA(1) SEGINI, MLOBJE ITLAC(**)=MLOBJE NM2 = 2 SEGINI, ITBBM2,itbbc3 IF (IFORM.NE.2) THEN CALL LFCDIM(IORES,NM2,ITABM2,IRETOU,IFORM) IF(IRETOU.NE.0) GOTO 1000 WRITE (TYPOBJ,FMT='(2A4)') ITABM2(1),ITABM2(2) ELSE ios=IXDRSTRING( ixdrr, itabc3(1)(1:nm2*4)) C write (6,*) ' TYPOBJ itabc3 ',itabc3(1),itabc3(2) TYPOBJ(1:4)=itabc3(1) TYPOBJ(5:8)=itabc3(2) ENDIF CALL LFCDIE(IORES,NOBJ,LISOBJ,IRETOU,IFORM) SEGDES, MLOBJE IF(IRETOU.NE.0) GOTO 1000 500 CONTINUE GOTO 1098 C ****************************************************************** C *****FIN DE LECTURE D'UNE PILE : NOM DES OBJETS******************* C 1098 CONTINUE C **** KCOLAC(IFILE)=IMAX1+ KCOLAC(IFILE) CALL CREOB (ITYPE,NOMM1,NOMM2,ITLACC,mianc,mranc,mlanc,mmanc) IF(IFIN.EQ.1) GOTO 1000 GOTO 1097 ********************* ON REBOUCLE EN LECTURE ********************** 1000 CONTINUE 1099 CONTINUE 1001 CONTINUE IRET=IRETOU IF(NOMM1.NE.0) SEGSUP NOMM1 IF(NOMM2.NE.0) SEGSUP NOMM2 IF (ITBBM1.NE.0) SEGSUP ITBBM1,itbbc1 IF (ITBBM2.NE.0) SEGSUP ITBBM2,itbbc3 IF (ITBBE1.NE.0) SEGSUP ITBBE1 IF (ITBBE2.NE.0) SEGSUP ITBBE2,itbbc2 IF (ITBBR1.NE.0) SEGSUP ITBBR1 SEGDES ICOLAC RETURN C ------------------------------------------------------- 8000 FORMAT(16I5) 8001 FORMAT(16(1X,A4)) END