C LIRUNV SOURCE PV 20/08/31 21:15:14 10703 C======================================================================= C Appele par : LIREFI C======================================================================= SUBROUTINE LIRUNV IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCREDLE -INC CCGEOME -INC SMCOORD -INC SMELEME -INC SMLENTI SEGMENT MLINOE.MLENTI,MLINO2.MLENTI,MLIEL2.MLENTI -INC SMTABLE C= Nombre de caracteres sur une ligne lue (cf. etiquette 1000) PARAMETER (NCARMAX = 80 , NCARFIN = NCARMAX+1) C= Unite logique du fichier d'impression au format UNV I-Deas/NX(TM) PARAMETER (IUUNV=67) CHARACTER*(LOCHAI) FicUnv PARAMETER (INCJG = 10000) PARAMETER (NEFUNV=86, NEFBIM=8, NEFPOI=1) INTEGER LEFUNV(NEFUNV), LEFGEO(NEFUNV), & LEFBIM(NEFBIM), LEFPOI(NEFPOI) DATA LEFUNV / 11, 21, 22, 23, 24, 31, 32, 41, 42, 43, & 44, 45, 46, 51, 52, 53, 54, 55, 56, 61, & 62, 63, 64, 65, 66, 71, 72, 73, 74, 75, & 76, 81, 82, 84, 85, 91, 92, 93, 94, 95, & 96, 101, 102, 103, 104, 105, 106, 111, 112, 113, & 114, 115, 116, 117, 118, 121, 122, 136, 137, 138, & 139, 141, 142, 151, 152, 161, 171, 172, 181, 191, & 192, 193, 194, 195, 196, 201, 202, 203, 204, 208, & 212, 213, 221, 222, 231, 232 / DATA LEFGEO / 2, 2, 2, 0, 3, 0, 0, 4, 6, 0, & 8, 10, 0, 4, 6, 0, 8, 10, 0, 4, & 6, 0, 8, 10, 0, 8, 6, 0, 4, 10, & 0, 4, 6, 8, 10, 4, 6, 0, 8, 10, & 0, 16, 17, 0, 14, 15, 0, 23, 16, 17, & 0, 14, 15, 0, 24, 2, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 1, 2, 3, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0 / DATA LEFBIM / 11, 21, 22, 23, 24, 31, 32, 121 / DATA LEFPOI / 161 / SEGMENT MLIELT INTEGER IELEM(JGEL,4) ENDSEGMENT SEGMENT MLISEF INTEGER ITYPE(JGEF,5) ENDSEGMENT SEGMENT MLIMAI POINTEUR PTMAI(JGMAI).MELEME INTEGER TYMAI(JGMAI) ENDSEGMENT SEGMENT MLIPHY INTEGER NUMPHY(JGPHY) CHARACTER*40 NOMPHY(JGPHY) POINTEUR PTPHY(JGPHY).MELEME ENDSEGMENT SEGMENT MLIPEG INTEGER NUMPEG(JGPEG,4) CHARACTER*40 NOMPEG(JGPEG) POINTEUR PTPEG(JGPEG).MELEME POINTEUR PTPEGN(JGPEG).MELEME ENDSEGMENT EXTERNAL LONG CHARACTER*8 mot_z CHARACTER*45 nom_z LOGICAL b_z C... Format de lecture 1000 FORMAT(A80) C* 1003 FORMAT(2x,d23.16,2x,d23.16,2x,d23.16) C* 1004 FORMAT(2x,i8) C* 1005 FORMAT(4x,a2) C* 1010 FORMAT(8(i10)) C... Lecture des arguments (obligatoires) C= Lecture du nom du fichier de donnees au format UNV de I-Deas/NX(TM) CALL LIRCHA(FicUnv,1,IRETOU) IF (IERR.NE.0) RETURN C... Initialisation de la table de sortie CALL CRTABL(MATAB) i_z = 0 r_z = 0. b_z = .FALSE. mot_z = ' ' nom_z = ' ' C... Segment de lecture d'une ligne ... SEGINI,sredle SEPARA=.FALSE. MOT=' ' NRAN=0 ICOUR=0 C... Configuration initiale IDIMI=IDIM WRITE(IOIMP,*) WRITE(IOIMP,FMT='(A,I2)') ' DIMEnsion initiale = ',IDIMI SEGACT,MCOORD*MOD NBANC=nbpts C... Passage temporaire en dimension 3 (si necessaire) iOK=0 IDIMF=3 IF (IDIMF.NE.IDIMI) THEN CALL ECRENT(IDIMF) CALL ECRCHA('DIME') CALL OPTION(1) IF (IERR.NE.0) GOTO 990 ENDIF C... Par defaut, on affiche erreur Cast3m numero 424 iOK=424 l=LONG(FicUnv) MOTERR=FicUnv(1:l) INTERR(1)=0 CLOSE(UNIT=IUUNV,ERR=990) WRITE(IOIMP,*) WRITE(IOIMP,*) 'Ouverture du fichier I-Deas/NX (TM)' OPEN(UNIT=IUUNV,STATUS='OLD',FILE=FicUnv(1:l), & IOSTAT=IOS,FORM='FORMATTED') C... Traitement des erreurs d ouverture des fichiers IF (IOS.NE.0) THEN iOK=599 INTERR(1)=IOS GOTO 990 ENDIF C... Quelques initialisations NBNPTS=0 NBELTS=0 NBEFLU=0 NBMAIS=0 NBPHYS=0 NBPEGR=0 MLINOE=0 MLINO2=0 MLIELT=0 MLIEL2=0 MLISEF=0 MLIMAI=0 MLIPHY=0 MLIPEG=0 C... Lecture des lignes du fichier ... I_BLOC=0 C... Recherche de l'indicateur "-1" en debut de bloc WRITE(IOIMP,*) WRITE(IOIMP,*) 'LECTURE DES DATASET' 10 CONTINUE READ(IUUNV,FMT=1000,ERR=991,END=100) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN CALL REDLEC(sredle) IF (IRE.NE.1) GOTO 10 IF (NFIX.NE.-1) GOTO 10 I_BLOC=1-I_BLOC IF (I_BLOC.EQ.0) GOTO 10 C... Lecture de la cle READ(IUUNV,FMT=1000,ERR=991,END=100) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN CALL REDLEC(sredle) IF (IRE.NE.1) THEN WRITE(IOIMP,*) 'ERREUR : Numero du DATASET non trouve' iOK=21 GOTO 991 ENDIF IF (NFIX.EQ. 151) GOTO 151 IF (NFIX.EQ. 164) GOTO 164 IF (NFIX.EQ.2411) GOTO 2411 IF (NFIX.EQ.2412) GOTO 2412 IF (NFIX.EQ.2470) GOTO 2470 IF (NFIX.EQ.2477) GOTO 2477 WRITE(IOIMP,*) 'ATTENTION : DATASET ',NFIX,' ignore' GOTO 10 C... Lecture de l'entete 151 CONTINUE WRITE(IOIMP,*) '-> LECTURE du DATASET 151' DO i = 1, 7 READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT IF (i.EQ.3) THEN * WRITE(IOIMP,*) TEXT(1:LONG(TEXT)) ELSE IF (i.EQ.6) THEN WRITE(IOIMP,*) ' Programme = ',TEXT(1:LONG(TEXT)) ENDIF ENDDO C... Fin du bloc READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT I_BLOC=1-I_BLOC WRITE(IOIMP,*) '<- Lecture du DATASET 151 terminee' GOTO 10 C... Lecture de l'entete 164 CONTINUE WRITE(IOIMP,*) '-> LECTURE du DATASET 164' * READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT READ(IUUNV,1640,ERR=991,END=991) i,TEXT,i 1640 FORMAT(I10,A20,I10) WRITE(IOIMP,*) ' Systeme d unite utilise = ',TEXT(1:LONG(TEXT)) C* WRITE(IOIMP,*) ' Facteurs de conversion d unite' NBVPR = 4 NBLIG = 0 DO i=1, NBVPR IF (NBLIG.EQ.3) NBLIG = 0 NBLIG = NBLIG + 1 IF (NBLIG.EQ.1) THEN READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT C* NRAN=0 C* ICOUR=NCARMAX C* IFINAN=NCARFIN ENDIF C* CALL REDLEC(sredle) ENDDO C... Fin du bloc READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT I_BLOC=1-I_BLOC WRITE(IOIMP,*) '<- Lecture du DATASET 164 terminee' GOTO 10 C Lecture des noeuds : numero, coordonnees (densite mise a zero) 2411 CONTINUE WRITE(IOIMP,*) '-> LECTURE du DATASET 2411' JG=INCJG SEGINI,MLINOE NBPTS=NBANC+JG SEGADJ,MCOORD NUMIN=100000000 NUMAX=0 idimp1=IDIM+1 ABS_Z = 0.D0 12411 CONTINUE C... Lecture des informations liees au noeud (RECORD 1) READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN CALL REDLEC(sredle) IF (IRE.NE.1) THEN iOK=8 GOTO 991 ENDIF C. Fin du bloc ? IF (NFIX.EQ.-1) GOTO 22411 IF (NFIX.EQ.0) THEN iOK=8 GOTO 991 ENDIF NBNPTS=NBNPTS+1 IF (NBNPTS.GT.JG) THEN JG=JG+INCJG SEGADJ,MLINOE NBPTS=NBANC+JG SEGADJ,MCOORD ENDIF MLINOE.LECT(NBNPTS)=NFIX NUMIN=MIN(NUMIN,NFIX) NUMAX=MAX(NUMAX,NFIX) C... Lecture des coordonnees (RECORD 2) READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN j=(NBANC+NBNPTS-1)*idimp1 DO k=1,IDIMF CALL REDLEC(sredle) IF (IRE.NE.1.AND.IRE.NE.2) THEN iOK=661 GOTO 991 ENDIF IF (IRE.EQ.1) THEN XCOOR(j+k)=NFIX ELSE XCOOR(j+k)=FLOT ENDIF ENDDO XCOOR(j+idimp1)=0.D0 ABS_Z = MAX(ABS_Z,ABS(XCOOR(j+IDIMF))) GOTO 12411 C... Fin du bloc 22411 CONTINUE WRITE(IOIMP,*) ' Nombre de noeuds lus :',NBNPTS WRITE(IOIMP,*) ' Numero du noeud min. :',NUMIN WRITE(IOIMP,*) ' Numero du noeud max. :',NUMAX WRITE(IOIMP,*) '<- Lecture du DATASET 2411 terminee' IF (NBNPTS.NE.JG) THEN JG = NBNPTS SEGADJ,MLINOE NBPTS = NBANC+JG SEGADJ,MCOORD ENDIF WRITE(IOIMP,*) IF (IDIMI.EQ.IDIMF) THEN WRITE(IOIMP,*) ' Noeuds lus en DIMEsion 3' ELSE IF (ABS_Z.GT.0.D0) THEN WRITE(IOIMP,*) ' Noeuds lus en DIMEnsion 3' WRITE(IOIMP,*) '=> Passage en DIMEnsion 3 necessaire' ELSE WRITE(IOIMP,*) ' Noeuds lus en DIMEnsion 2' IF (IDIMI.NE.2) THEN WRITE(IOIMP,*) '=> Passage en DIMEnsion 2 necessaire' ENDIF IDIMF = 2 CALL ECRENT(IDIMF) CALL ECRCHA('DIME') CALL OPTION(1) IF (IERR.NE.0) GOTO 990 ENDIF ENDIF WRITE(IOIMP,*) I_BLOC=1-I_BLOC GOTO 10 C... Lecture des elements 2412 CONTINUE WRITE(IOIMP,*) '-> LECTURE du DATASET 2412' JGEF = 50 SEGINI,MLISEF JGEL = INCJG SEGINI,MLIELT NUMIN = 100000000 NUMAX = 0 12412 CONTINUE C... Lecture des informations liees a l'element (RECORD 1) READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN DO i=1,6 CALL REDLEC(sredle) IF (IRE.NE.1) THEN iOK=8 GOTO 991 ENDIF IF (i.EQ.1) THEN IF (NFIX.EQ.-1) GOTO 22412 NUMELT=NFIX ELSE IF (i.EQ.2) THEN NUMEF=NFIX ELSE IF (i.EQ.3) THEN NUMPP=NFIX C* ELSE IF (i.EQ.4) THEN C* NUMMP=NFIX C* ELSE IF (i.EQ.5) THEN C* NUMCO=NFIX ELSE IF (i.EQ.6) THEN NBNOE=NFIX ENDIF ENDDO CALL PLACE2(LEFBIM,NEFBIM,IRETOU,NUMEF) C... Lecture des informations d un element type "BEAM" C... Pour l'instant pas de traitement de ces informations IF (IRETOU.NE.0) THEN READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT ENDIF NBELTS=NBELTS+1 IF (NBELTS.GT.JGEL) THEN JGEL=JGEL+INCJG SEGADJ,MLIELT ENDIF NUMIN=MIN(NUMIN,NUMELT) NUMAX=MAX(NUMAX,NUMELT) DO i=1,NBEFLU IF (NUMEF.EQ.ITYPE(i,1)) GOTO 24120 ENDDO NBEFLU = NBEFLU+1 ITYPE(NBEFLU,1) = NUMEF ITYPE(NBEFLU,2) = NBNOE JG = 1*NBNOE SEGINI,MLENTI ITYPE(NBEFLU,5) = MLENTI i = NBEFLU 24120 CONTINUE IF (NBNOE.NE.ITYPE(i,2)) THEN write(IOIMP,*) 'Erreur NUMEF/NBNOE',NBELTS,NUMELT ENDIF NBELEF=ITYPE(i,3)+1 ITYPE(i,3)=NBELEF MLENTI=ITYPE(i,5) JG=LECT(/1) NBNOEF=NBELEF*NBNOE IF (NBNOEF.GT.JG) THEN JG=JG+INCJG SEGADJ,MLENTI ENDIF NBNOEF=NBNOEF-NBNOE IELEM(NBELTS,1)=NUMELT IELEM(NBELTS,2)=NUMPP IELEM(NBELTS,3)=i IELEM(NBELTS,4)=NBELEF C... Lecture des noeuds de l'element (RECORD 2) j=0 DO k=NBNOEF+1,NBNOEF+NBNOE j=j+1 IF (j.EQ.1) THEN READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN ENDIF CALL REDLEC(sredle) IF (IRE.NE.1) THEN iOK=661 GOTO 991 ENDIF LECT(k)=NFIX IF (j.EQ.8) j=0 ENDDO GOTO 12412 C... Fin du bloc 22412 CONTINUE WRITE(IOIMP,*) ' Nombre d elements lus :',NBELTS WRITE(IOIMP,*) ' Numero d element min. :',NUMIN WRITE(IOIMP,*) ' Numero d element max. :',NUMAX WRITE(IOIMP,*) ' Nombre de types EF lus :',NBEFLU IF (NBELTS.NE.JGEL) THEN JGEL=NBELTS SEGADJ,MLIELT ENDIF I_BLOC=1-I_BLOC WRITE(IOIMP,*) '<- Lecture du DATASET 2412 terminee' GOTO 10 C Lecture des proprietes physiques 2470 CONTINUE WRITE(IOIMP,*) '-> LECTURE du DATASET 2470' NBPHYS = 0 JGPHY = 50 SEGINI,MLIPHY 12470 CONTINUE C... Lecture des donnees/proprietes physiques (RECORD 1) READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN DO i=1,3 CALL REDLEC(sredle) IF (IRE.NE.1) THEN iOK=8 GOTO 991 ENDIF IF (i.EQ.1) THEN IF (NFIX.EQ.-1) GOTO 22470 NUMPH=NFIX C* ELSE IF (i.EQ.2) THEN C* IDPHT=NFIX ELSE IF (i.EQ.3) THEN NBPHT=NFIX ENDIF ENDDO NBPHYS=NBPHYS+1 IF (NBPHYS.GT.JGPHY) THEN JGPHY=JGPHY+50 SEGADJ,MLIPHY ENDIF NUMPHY(NBPHYS)=NUMPH C... Lecture du nom de la propriete (RECORD 2) READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NOMPHY(NBPHYS)=TEXT(1:LONG(TEXT)) C... Lecture des valeurs de chaque propriete physique (RECORD 3 et 4) C... Pour l'instant : pas de traitement de ces valeurs DO i = 1, NBPHT READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN DO j=1,3 CALL REDLEC(sredle) IF (IRE.NE.1) THEN iOK=8 GOTO 991 ENDIF IF (j.EQ.1) THEN C* NUMPR=NFIX ELSE IF (j.EQ.2) THEN IDTPR=NFIX ELSE IF (j.EQ.3) THEN NBVPR=NFIX ENDIF ENDDO NBLIG=0 IF (IDTPR.EQ.1) THEN NBLIG = ((NBVPR-1) / 8) + 1 ELSE IF (IDTPR.EQ.2) THEN NBLIG = ((NBVPR-1) / 5) + 1 ELSE IF (IDTPR.EQ.3) THEN NBLIG = ((NBVPR-1) / 80) + 1 ENDIF DO j=1,NBLIG READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT ENDDO ENDDO GOTO 12470 C... Fin du bloc 22470 CONTINUE WRITE(IOIMP,*) ' Nombre de proprietes lues :',NBPHYS DO i=1,NBPHYS j=LONG(NOMPHY(i)) WRITE(IOIMP,FMT='(3X,I2,3H = ,A)') NUMPHY(i),NOMPHY(i)(1:j) ENDDO c* IF (NBPHYS.NE.JGPHY) THEN c* JGPHY = NBPHYS c* SEGADJ,MLIPHY c* ENDIF I_BLOC=1-I_BLOC WRITE(IOIMP,*) '<- Lecture du DATASET 2470 terminee' GOTO 10 C Lecture des groupes (d'elements) "permanents" 2477 CONTINUE WRITE(IOIMP,*) '-> LECTURE du DATASET 2477' NBPEGR = 0 NBPEGP = 0 NBPEGE = 0 JGPEG = 50 SEGINI,MLIPEG 12477 CONTINUE C... Lecture des donnees... (RECORD 1) READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN DO i = 1, 8 CALL REDLEC(sredle) IF (IRE.NE.1) THEN iOK=8 GOTO 991 ENDIF IF (i.EQ.1) THEN IF (NFIX.EQ.-1) GOTO 22477 NUMPH = NFIX ELSE IF (i.EQ.8) THEN NBPHT = NFIX ENDIF ENDDO NBPEGR = NBPEGR+1 IF (NBPEGR.GT.JGPEG) THEN JGPEG = JGPEG+50 SEGADJ,MLIPEG ENDIF NUMPEG(NBPEGR,1) = NUMPH JG = NBPHT SEGINI,MLENTI NUMPEG(NBPEGR,2) = MLENTI C... Lecture du nom du groupe (RECORD 2) READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT j = LONG(TEXT) NOMPEG(NBPEGR) = TEXT(1:j) WRITE(IOIMP,FMT='(4X,9HGroupe lu,3X,I2,3H = ,A)') & NUMPH,NOMPEG(NBPEGR) C... Lecture de chaque entite du groupe i = 0 kelt = 0 knoe = NBPHT+1 k = 0 32477 CONTINUE k = k + 1 IF (k.EQ.1) THEN READ(IUUNV,FMT=1000,ERR=991,END=991) TEXT NRAN=0 ICOUR=NCARMAX IFINAN=NCARFIN ELSE k = 0 ENDIF DO j = 1, 4 CALL REDLEC(sredle) IF (IRE.NE.1) THEN IF (j.EQ.1) THEN IF (k.EQ.1) THEN iOK=8 GOTO 991 ELSE GOTO 32477 ENDIF ENDIF ENDIF IF (j.EQ.1) THEN IDPTR=NFIX ELSE IF (j.EQ.2) THEN NUMPR=NFIX ENDIF ENDDO i = i + 1 C... On ne conserve que les noeuds (POI1) et les elements IF (IDPTR.EQ.7) THEN knoe = knoe - 1 LECT(knoe) = NUMPR ELSE IF (IDPTR.EQ.8) THEN kelt = kelt + 1 LECT(kelt) = NUMPR ENDIF IF (i.EQ.NBPHT) GOTO 42477 GOTO 32477 42477 CONTINUE knoe = NBPHT+1 - knoe NUMPEG(NBPEGR,3) = knoe NUMPEG(NBPEGR,4) = kelt IF (knoe.GT.0) NBPEGP = NBPEGP+1 IF (kelt.GT.0) NBPEGE = NBPEGE+1 IF (knoe.EQ.0 .AND. kelt.EQ.0) THEN NBPEGR = NBPEGR-1 SEGSUP,MLENTI ENDIF GOTO 12477 C... Fin du bloc 22477 CONTINUE WRITE(IOIMP,*) ' Nombre de groupes conserves :',NBPEGR DO i = 1, NBPEGR j = LONG(NOMPEG(i)) IF (NUMPEG(i,4).EQ.0) THEN WRITE(IOIMP,FMT=2001) NUMPEG(i,1),NOMPEG(i)(1:j) ELSE IF (NUMPEG(i,3).EQ.0) THEN WRITE(IOIMP,FMT=2002) NUMPEG(i,1),NOMPEG(i)(1:j) ELSE WRITE(IOIMP,FMT=2000) NUMPEG(i,1) WRITE(IOIMP,FMT=2002) NUMPEG(i,1),NOMPEG(i)(1:j)//' ' WRITE(IOIMP,FMT=2001) NUMPEG(i,1),NOMPEG(i)(1:j)//'_GN' ENDIF ENDIF ENDDO 2000 FORMAT(4X,I4,' ==> Groupe separe en 2 parties :') 2001 FORMAT(4X,I4,' = ',A,' -> GroupeNoeuds') 2002 FORMAT(4X,I4,' = ',A,' -> GroupeElements') c* IF (NBPEGR.NE.JGPEG) THEN c* JGPEG = NBPEGR c* SEGADJ,MLIPEG c* ENDIF I_BLOC = 1-I_BLOC WRITE(IOIMP,*) '<- Lecture du DATASET 2477 terminee' GOTO 10 C= Fin normale de la lecture 100 CONTINUE WRITE(IOIMP,*) 'FIN LECTURE DES DATASET' C= Traitement des differents DATASET lus C= Creation d'une liste croissante des noeuds selon leur numero lu C= Creation d'un maillage de POI1 contenant tous les noeuds lus C* Mettre une option pour creer ce maillage ? IF (MLINOE.NE.0) THEN NBNN=1 NBELEM=NBNPTS NBSOUS=0 NBREF=0 SEGINI,MELEME ITYPEL=1 DO i=1,NBNPTS NUM(1,i)=i+NBANC ENDDO SEGDES,MELEME CALL ECCTAB(MATAB,'MOT ',i_z,r_z,'NOEUDS',b_z, i_z , & 'MAILLAGE',i_z,r_z, mot_z ,b_z,MELEME) JG = NBNPTS SEGINI,MLINO2 MLINO2.LECT(1)=1 DO i=2,NBNPTS INOE = MLINOE.LECT(i) DO j=i-1,1,-1 JNO2 = MLINO2.LECT(j) JNOE = MLINOE.LECT(JNO2) IF (JNOE.LE.INOE) GOTO 101 MLINO2.LECT(j+1) = JNO2 ENDDO 101 CONTINUE MLINO2.LECT(j+1) = i ENDDO ENDIF C= Creation du maillage contenant l'ensemble des elements lus ayant C= une correspondance dans Cast3m IF (MLIELT.NE.0) THEN IF (MLINOE.EQ.0) THEN WRITE(IOIMP,*) 'ERREUR : DATASET 2411 non lu' iOK = 21 GOTO 991 ENDIF JGMAI = NBEFLU SEGINI,MLIMAI NBSOUS=0 NBREF=0 NBMAIS=0 icoul=0 DO i = 1, NBEFLU NUMEF = ITYPE(i,1) C* IF (NUMEF.LE.0) GOTO 110 CALL PLACE2(LEFUNV,NEFUNV,IRETOU,NUMEF) IF (IRETOU.EQ.0) THEN WRITE(IOIMP,*) 'FE ID non reconnu : ',NUMEF GOTO 110 ENDIF IF (LEFGEO(IRETOU).EQ.0) THEN WRITE(IOIMP,*) NUMEF,' sans correspondance dans C3M' GOTO 110 ENDIF NBNN =ITYPE(i,2) NBELEM=ITYPE(i,3) MLENTI=ITYPE(i,5) icoul = icoul + 1 IF (icoul.EQ.NBCOUL) icoul=1 NBMAIS=NBMAIS+1 C* ITYPE(i,1)=LEFGEO(IRETOU) ITYPE(i,4)=NBMAIS SEGINI,PTMAI(NBMAIS) IPT1=PTMAI(NBMAIS) IPT1.ITYPEL=LEFGEO(IRETOU) TYMAI(NBMAIS)=LEFGEO(IRETOU) NBNOEL=0 DO j = 1, NBELEM DO k = 1, NBNN INOE = LECT(NBNOEL+k) lInf = 1 lSup = NBNPTS 111 CONTINUE IF (lInf.GT.lSup) THEN WRITE(IOIMP,*) 'ERREUR : Noeud',INOE,'pas dans 2411' iOK=21 GOTO 991 ENDIF lMil = (lInf+lSup)/2 l = MLINO2.LECT(lMil) JNOE = MLINOE.LECT(l) IF (INOE.EQ.JNOE) THEN GOTO 112 ELSE IF (INOE.LT.JNOE) THEN lSup = lMil - 1 ELSE lInf = lMil + 1 ENDIF GOTO 111 112 CONTINUE IPT1.NUM(k,j) = NBANC+l LECT(NBNOEL+k) = NBANC+l ENDDO IPT1.ICOLOR(j)=icoul NBNOEL=NBNOEL+NBNN ENDDO SEGDES,PTMAI(NBMAIS) 110 CONTINUE MLENTI = ITYPE(i,5) SEGDES,MLENTI ENDDO IF (JGMAI.NE.NBMAIS) THEN JGMAI=NBMAIS SEGADJ,MLIMAI ENDIF IF (NBMAIS.EQ.0) THEN WRITE(IOIMP,*) 'Pas de maillage au sens Cast3m' CALL ECCTAB(MATAB,'MOT ',i_z,r_z,'MAILLAGE',b_z,i_z, & 'MOT ',i_z,r_z, 'VIDE' ,b_z,i_z) ELSE nom_z(1:5) = '@ ' DO i = 1, NBMAIS IPT1=PTMAI(i) j =TYMAI(i) nom_z(2:5) = NOMS(j)(1:4) CALL ECCTAB(MATAB,'MOT ',i_z,r_z,nom_z(1:5),b_z,i_z , & 'MAILLAGE',i_z,r_z, mot_z ,b_z,IPT1) ENDDO IF (NBMAIS.EQ.1) THEN IPT2=PTMAI(1) ELSE NBSOUS=NBMAIS NBREF =0 NBNN =0 NBELEM=0 SEGINI,IPT2 DO i = 1, NBSOUS IPT2.LISOUS(i)=PTMAI(i) ENDDO SEGDES,IPT2 ENDIF CALL ECCTAB(MATAB,'MOT ',i_z,r_z,'MAILLAGE',b_z,i_z , & 'MAILLAGE',i_z,r_z, mot_z ,b_z,IPT2) ENDIF ENDIF C= Creation des maillages (groupes d'elements) associes a chaque C= propriete physique lue (elements avec une correspondance dans Cast3m) IF (MLIPHY.NE.0) THEN IF (MLIELT.EQ.0) THEN WRITE(IOIMP,*) 'ERREUR : DATASET 2412 non lu' iOK = 21 GOTO 991 ENDIF IF (NBMAIS.EQ.0) THEN WRITE(IOIMP,*) 'Pas de GROUPE associe aux proprietes' ELSE JG=NBMAIS SEGINI,MLENTI,MLENT1 DO j=1,NBMAIS SEGACT,PTMAI(j) ENDDO icoul = 1 DO i = 1, NBPHYS NUMPP = NUMPHY(i) PTPHY(i) = 0 DO j=1,NBMAIS LECT(j)=0 MLENT1.LECT(j)=0 ENDDO DO j=1,NBELTS IF (IELEM(j,2).EQ.NUMPP) THEN k = ITYPE(IELEM(j,3),4) IF (k.NE.0) LECT(k)=LECT(k)+1 ENDIF ENDDO NMAIPH=0 NBSOUS=0 NBREF =0 DO j=1,NBMAIS NBELEM=LECT(j) IF (NBELEM.NE.0) THEN NMAIPH=NMAIPH+1 IPT1=PTMAI(j) NBNN=IPT1.NUM(/1) SEGINI,MELEME ITYPEL=IPT1.ITYPEL DO k=1,NBELEM ICOLOR(k)=icoul ENDDO LECT(j)=MELEME ENDIF ENDDO IF (NMAIPH.EQ.0) GOTO 120 DO j=1,NBELTS IF (IELEM(j,2).EQ.NUMPP) THEN k = ITYPE(IELEM(j,3),4) IF (k.NE.0) THEN IPT1 =PTMAI(k) MELEME=LECT(k) NBNN = NUM(/1) iel1 = IELEM(j,4) iel2 = MLENT1.LECT(k)+1 DO l=1,NBNN NUM(l,iel2)=IPT1.NUM(l,iel1) ENDDO MLENT1.LECT(k) = iel2 ENDIF ENDIF ENDDO DO j=1,NBMAIS MELEME=LECT(j) IF (MELEME.NE.0) SEGDES,MELEME ENDDO IF (NMAIPH.EQ.1) THEN DO j=1,NBMAIS MELEME=LECT(j) IF (MELEME.NE.0) PTPHY(i)=MELEME ENDDO ELSE NBNN=0 NBREF=0 NBSOUS=NMAIPH SEGINI,MELEME ISOUS=0 DO j=1,NBMAIS IPT1=LECT(j) IF (IPT1.NE.0) THEN ISOUS=ISOUS+1 LISOUS(ISOUS)=IPT1 ENDIF ENDDO SEGDES,MELEME PTPHY(i)=MELEME ENDIF icoul = icoul + 1 IF (icoul.EQ.16) icoul=icoul-15 120 CONTINUE ENDDO SEGSUP,MLENTI,MLENT1 DO j=1,NBMAIS SEGDES,PTMAI(j) ENDDO DO i = 1, NBPHYS IPT1=PTPHY(i) IF (IPT1.NE.0) THEN nom_z = NOMPHY(i) CALL ECCTAB(MATAB,'MOT ',i_z,r_z,nom_z,b_z,i_z, & 'MAILLAGE',i_z,r_z,mot_z,b_z,IPT1) ENDIF ENDDO ENDIF ENDIF C= Creation des groupes de noeuds ou d'elements ("permanents") C= Pour permettre la lecture d'"anciens" fichiers UNV... IF (MLIPEG.NE.0) THEN IF (MLIELT.EQ.0) THEN WRITE(IOIMP,*) 'ERREUR : DATASET 2412 non lu' iOK = 21 GOTO 991 ENDIF C= Creation d'une liste croissante des elements selon leur numero lu C= (uniquement s'il y des elements dans les groupes "permanents") IF (NBPEGE.NE.0) THEN JG = NBELTS SEGINI,MLIEL2 MLIEL2.LECT(1) = 1 DO i = 2, NBELTS INOE = IELEM(i,1) DO j = i-1, 1, -1 JNO2 = MLIEL2.LECT(j) JNOE = IELEM(JNO2,1) IF (JNOE.LE.INOE) GOTO 130 MLIEL2.LECT(j+1) = JNO2 ENDDO 130 CONTINUE MLIEL2.LECT(j+1) = i ENDDO ENDIF C* icoul = 1 JG = NBEFLU SEGINI,MLENT1 DO i = 1, NBPEGR DO j = 1, NBEFLU MLENT1.LECT(j) = 0 ENDDO c* NUMPH = NUMPEG(i,1) MLENTI = NUMPEG(i,2) knoe = NUMPEG(i,3) kelt = NUMPEG(i,4) PTPEG(i) = 0 PTPEGN(i) = 0 MELPOI = 0 IF (knoe.EQ.0) GOTO 133 NBNN = 1 NBELEM = knoe NBREF = 0 NBSOUS = 0 SEGINI,MELEME ITYPEL = 1 NBPHT = LECT(/1) - knoe DO k = 1, knoe INOE = LECT(NBPHT+k) lInf = 1 lSup = NBNPTS 131 CONTINUE IF (lInf.GT.lSup) THEN WRITE(IOIMP,*) 'ERREUR : Noeud',INOE,'pas dans 2411' iOK = 21 GOTO 991 ENDIF lMil = (lInf+lSup)/2 l = MLINO2.LECT(lMil) JNOE = MLINOE.LECT(l) IF (INOE.EQ.JNOE) THEN GOTO 132 ELSE IF (INOE.LT.JNOE) THEN lSup = lMil - 1 ELSE lInf = lMil + 1 ENDIF GOTO 131 132 CONTINUE NUM(1,k) = NBANC+l ICOLOR(k) = icoul ENDDO SEGDES,MELEME MELPOI = MELEME PTPEG(i) = MELPOI IF (kelt.EQ.0) GOTO 137 133 CONTINUE PTPEGN(i) = MELPOI DO k = 1, kelt INOE = LECT(k) lInf = 1 lSup = NBELTS 134 CONTINUE IF (lInf.GT.lSup) THEN WRITE(IOIMP,*) 'ERREUR : Element',INOE,'pas dans 2412' iOK = 21 GOTO 991 ENDIF lMil = (lInf+lSup)/2 l = MLIEL2.LECT(lMil) JNOE = IELEM(l,1) IF (INOE.EQ.JNOE) THEN GOTO 135 ELSE IF (INOE.LT.JNOE) THEN lSup = lMil - 1 ELSE lInf = lMil + 1 ENDIF GOTO 134 135 CONTINUE LECT(k) = l JNOE = IELEM(l,3) MLENT1.LECT(JNOE) = MLENT1.LECT(JNOE) + 1 ENDDO NBMAIS = 0 NBREF = 0 NBSOUS = 0 DO j = 1, NBEFLU NBELEM = MLENT1.LECT(j) IF (NBELEM.EQ.0) GOTO 136 NBMAIS = NBMAIS + 1 NUMEF = ITYPE(j,4) NBNN = ITYPE(j,2) IPT1 = PTMAI(NUMEF) SEGACT,IPT1 SEGINI,MELEME ITYPEL = IPT1.ITYPEL iel2 = 0 DO k = 1, kelt JNOE = LECT(k) l = ITYPE(IELEM(JNOE,3),4) IF (l.EQ.NUMEF) THEN iel1 = IELEM(JNOE,4) iel2 = iel2 + 1 DO l = 1, NBNN NUM(l,iel2) = IPT1.NUM(l,iel1) ENDDO ICOLOR(iel2) = icoul ENDIF ENDDO SEGDES,IPT1,MELEME MLENT1.LECT(j) = MELEME 136 CONTINUE ENDDO IF (NBMAIS.EQ.1) THEN IPT2 = MELEME ELSE NBNN = 0 NBELEM = 0 NBREF = 0 NBSOUS = NBMAIS SEGINI,IPT2 ISOUS = 0 DO j = 1, NBEFLU IPT1 = MLENT1.LECT(j) IF (IPT1.NE.0) THEN ISOUS = ISOUS + 1 IPT2.LISOUS(ISOUS) = IPT1 ENDIF ENDDO SEGDES,IPT2 ENDIF PTPEG(i) = IPT2 137 CONTINUE icoul = icoul + 1 IF (icoul.EQ.16) icoul = icoul-15 ENDDO DO i = 1, NBPEGR IPT1 = PTPEG(i) j = LONG(NOMPEG(i)) nom_z = NOMPEG(i)(1:j) CALL ECCTAB(MATAB,'MOT ',i_z,r_z,nom_z,b_z,i_z, & 'MAILLAGE',i_z,r_z,mot_z,b_z,IPT1) IPT1 = PTPEGN(i) IF (IPT1.NE.0) THEN nom_z = NOMPEG(i)(1:j)//'_GN' CALL ECCTAB(MATAB,'MOT ',i_z,r_z,nom_z,b_z,i_z, & 'MAILLAGE',i_z,r_z,mot_z,b_z,IPT1) ENDIF ENDDO ENDIF C= Ecriture de la TABLE contenant les donnees lues ! iOK = 0 CALL ECROBJ('TABLE ',MATAB) C= Menage et traitement des erreurs 991 CONTINUE CLOSE(UNIT=IUUNV) IF (MLINOE.NE.0) SEGSUP,MLINOE IF (MLINO2.NE.0) SEGSUP,MLINO2 IF (MLIELT.NE.0) SEGSUP,MLIELT IF (MLIEL2.NE.0) SEGSUP,MLIEL2 IF (MLISEF.NE.0) THEN DO i = 1, NBEFLU MLENTI = ITYPE(i,5) SEGSUP,MLENTI ENDDO SEGSUP,MLISEF ENDIF IF (MLIMAI.NE.0) SEGSUP,MLIMAI IF (MLIPHY.NE.0) SEGSUP,MLIPHY IF (MLIPEG.NE.0) THEN DO i = 1, NUMPEG(/1) MLENTI = NUMPEG(i,2) IF (MLENTI.NE.0) SEGSUP,MLENTI ENDDO SEGSUP,MLIPEG ENDIF 990 CONTINUE SEGSUP,sredle MTABLE=MATAB SEGDES,MTABLE C= Traitement des erreurs IF (iOK.NE.0 .OR. IERR.NE.0) THEN IF (iOK.NE.0) CALL ERREUR(iOK) SEGSUP,MTABLE WRITE(IOIMP,*) WRITE(IOIMP,*) 'Retour a la configuration initiale' NBPTS = NBANC SEGADJ,MCOORD IF (IDIMI.NE.0) THEN CALL ECRENT(IDIMI) CALL ECRCHA('DIME') CALL OPTION(1) ELSE IDIM = IDIMI ENDIF ENDIF WRITE(IOIMP,*) RETURN END