C SORTIR SOURCE PV 22/01/11 21:16:33 11258 C SORTIE DE GIBI C CE SOUS PROGRAMME PREPARE LE FICHIER DE SORTIE DE GIBI C IL COMMENCE PAR EFFACER LES ENREGISTREMENTS DE MEME NOM C DANS LE FICHIER DE COMMUNICATION (A FAIRE) C PUIS ECRIT UN ENREGISTREMENT (IMAGE DE CARTES) DONT LE C NOM EST LE NOM D L'OBJET A PERFORER C SUBROUTINE SORTIR(MELEME) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC CCGEOME -INC SMCOORD -INC TMLNOMS SEGMENT JSGTR(0) SEGMENT CSGT CHARACTER*8 CSGTR(0) ENDSEGMENT SEGMENT ISGT INTEGER ISGTR(0) ENDSEGMENT SEGMENT ILIST(ILL) SEGMENT ITLAC(0) POINTEUR ITLAC1.ITLAC CHARACTER*8 NOBJ CHARACTER*(8) CHAR CHARACTER*4 BLAN DATA BLAN /' '/ SEGINI ITLAC CALL QUENOM(NOBJ) REWIND IOPER SEGACT MELEME CALL AJOU(ITLAC,MELEME) IF(LISOUS(/1).NE.0) THEN DO 2 I=1,LISOUS(/1) IVAL=LISOUS(I) CALL AJOU(ITLAC,IVAL) 2 CONTINUE ENDIF CALL TASSPO(ITLAC,icolac,ipt8,0,1) segini,ITLAC1=ITLAC CALL SUPPIL(ICOLAC,-1) ITLAC=ITLAC1 segsup ipt8 IF (IERR.NE.0) RETURN C LES POINTS SONT CLASSES AVEC EN TETE CEUX DE L'OBJET QUI NOUS C INTERESSE C RECHERCHONS LE PLUS GRAND POINT A SORTIR CG Déja activé.... CG SEGACT MCOORD SEGACT MELEME IMAX=0 DO 5 IK=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0)THEN IPT1=LISOUS(IK) SEGACT IPT1 ELSE IPT1=MELEME ENDIF DO 3 J=1,IPT1.NUM(/2) DO 31 I=1,IPT1.NUM(/1) IMAX=MAX(IMAX,IPT1.NUM(I,J)) 31 CONTINUE 3 CONTINUE IF (LISOUS(/1).NE.0) SEGDES IPT1 5 CONTINUE SEGDES MELEME C ICI IL FAUDRA RENUMEROTER D'APRES OBJET LES POINTS JUSQU'A IMAX C ECRITURE DES ENREGISTREMENTS.POSITIONNEMENT A FAIRE QUAND ON SAURA C COMMENT EST FAIT LE FICHIER C PREMIER ENREGISTREMENT WRITE (IOPER,100) NOBJ,TITREE 100 FORMAT (A8,A72) C DEUXIEME ENREGISTREMENT IF( IONIVE . EQ. 0 ) WRITE (IOPER,1010) IF( IONIVE . EQ. 1 ) WRITE (IOPER,1011) IF( IONIVE . GE. 2 ) WRITE (IOPER,1012) 1010 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 000 16/01/1983') 1011 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 001 01/09/1985') 1012 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 002 29/07/1987') C PARAMETRES DU MAILLAGE WRITE (IOPER,102) IERMAX,IDIM,DENSIT 102 FORMAT('ERREUR',I4,' DIMENSION',I4,' DENSITE ',1PE12.5) C COORDONNEES (IDIM+DENS) WRITE(IOPER,103) IMAX 103 FORMAT ('NOMBRE DE POINTS ',I8) ILONG=(IDIM+1)*IMAX WRITE (IOPER,104) (XCOOR(I),I=1,ILONG) 104 FORMAT (1P,6E12.5) C CONSTRUCTION DE LA TABLE DES POINTS A PERFORER SEGINI CSGT,ISGT CALL REPERT('POINT ',ITITI) IF(ITITI.NE.0) THEN CALL REPLIS('POINT ',MLNOMS) ICO=1 DO 11 I=1,ITITI CALL LIROBJ('POINT ',IP1,1,IRETOU) IF(IERR.NE.0) RETURN IF (IP1.EQ.0) GOTO 11 IF(IP1.GT.IMAX) GOTO 11 ISGTR(**)=IP1 CSGTR(**)=LINOMS(I) ICO=ICO+3 11 CONTINUE SEGSUP MLNOMS 12 ENDIF C POINTS NOMMES ILONG=ISGTR(/1) WRITE (IOPER,105) ILONG 105 FORMAT('NOMBRE DE POINTS NOMMES',I8) IF (ILONG.NE.0) THEN WRITE (IOPER,106)(CSGTR(I),ISGTR(I),I=1,ILONG) 106 FORMAT (5(A8,I8)) 50 ENDIF C LISTE DES OBJETS A PERFORER SEGSUP ISGT,CSGT SEGINI JSGTR CALL QUIDAN(JSGTR,ITLAC,IMAX) SEGSUP ITLAC C DANS JSGTR LISTE DES OBJETS A PERFORER C ON LES PERFORE EN REMPLACANT LES REFERENCES AUX OBJETS POINTES C ET EN METTANT LE TYPE DE L'ELEMENT EN CLAIR ILONG=JSGTR(/1) WRITE (IOPER,107) ILONG 107 FORMAT('NOMBRE D''OBJETS ',I8) DO 20 I=1,ILONG MELEME=JSGTR(I) SEGACT MELEME*MOD IF (IONIVE.LE.1) THEN IF (ITYPEL.EQ.0) THEN WRITE (IOPER,108) BLAN,LISOUS(/1),LISREF(/1),NUM(/1),NUM(/2) ELSE WRITE (IOPER,108) NOMS(ITYPEL),LISOUS(/1),LISREF(/1),NUM(/1), # NUM(/2) ENDIF ELSE IF (ITYPEL.EQ.0) THEN WRITE (IOPER,1108) BLAN,LISOUS(/1),LISREF(/1),NUM(/1),NUM(/2) ELSE WRITE (IOPER,1108) NOMS(ITYPEL),LISOUS(/1),LISREF(/1),NUM(/1), # NUM(/2) ENDIF ENDIF 108 FORMAT(A4,' SOUS OBJETS',I4,' REFERENCES',I4,' NB NOEUDS',I4, # ' NB ELEM',I4) 1108 FORMAT(A4,' SOUS OBJETS',I4,' REFERENCES',I4,' NB NOEUDS',I4, # ' NBELEM',I5) IF (LISOUS(/1).NE.0) THEN ILL=LISOUS(/1) SEGINI ILIST DO 22 J=1,LISOUS(/1) JOB=LISOUS(J) DO 23 K=1,JSGTR(/1) IF (JOB.EQ.JSGTR(K)) GOTO 24 23 CONTINUE CALL ERREUR(9) RETURN 24 ILIST(J)=K 22 CONTINUE WRITE (IOPER,109) (ILIST(L),L=1,ILL) 109 FORMAT (20I4) SEGSUP ILIST 21 ENDIF IF (LISREF(/1).NE.0) THEN ILL=LISREF(/1) SEGINI ILIST DO 26 J=1,ILL JOB=LISREF(J) DO 27 K=1,JSGTR(/1) IF (JOB.EQ.JSGTR(K)) GOTO 28 27 CONTINUE CALL ERREUR(9) RETURN 28 ILIST(J)=K 26 CONTINUE WRITE (IOPER,110) (ILIST(L),L=1,ILL) 110 FORMAT(20I4) SEGSUP ILIST 25 ENDIF NBNN=NUM(/1) NBELEM=NUM(/2) IF (NBNN*NBELEM.EQ.0) GOTO 30 IF (IONIVE.NE.0) THEN DO 1140 L1= 1,NBELEM IF(ICOLOR(L1).EQ.0) ICOLOR(L1)=IDCOUL 1140 CONTINUE WRITE (IOPER,114) (NCOUL(ICOLOR(L1)),L1=1,NBELEM) 114 FORMAT (16(1X,A4)) ENDIF WRITE (IOPER,111) ((NUM(L1,L2),L1=1,NBNN),L2=1,NBELEM) 111 FORMAT (16I5) 30 CONTINUE SEGDES MELEME 20 CONTINUE C IL NE RESTE PLUS QUE LA LISTE DES NOMS D'OBJETS A SORTIR ILL=JSGTR(/1)*3 SEGINI ILIST ICO=0 CALL REPERT('MAILLAGE',ITITI) CALL REPLIS('MAILLAGE',MLNOMS) SEGACT MLNOMS DO 40 I=1,ITITI CALL LIROBJ('MAILLAGE',IOB,1,IRETOU) IF(IERR.NE.0) RETURN IF (IOB.EQ.0) GOTO 40 DO 41 J=1,JSGTR(/1) IF (IOB.EQ.JSGTR(J)) GOTO 42 41 CONTINUE GOTO 40 42 CONTINUE IF (ICO+3.GT.ILIST(/1)) THEN ILIST(**)=0 ILIST(**)=0 ILIST(**)=0 43 ENDIF ICO=ICO+1 READ(LINOMS(I),FMT='(2A4)')ILIST(ICO),ILIST(ICO+1) ICO=ICO+2 ILIST(ICO)=J 40 CONTINUE ILONG=ICO/3 WRITE (IOPER,112) ILONG 112 FORMAT('NOMBRE D''OBJETS NOMMES',I8) WRITE (IOPER,113) (ILIST(I),I=1,ICO) 113 FORMAT (5(2A4,I8)) SEGSUP ILIST,JSGTR RETURN END