1 : C SORTIR SOURCE PV 12/12/06 21:15:27 7594 2 : C SORTIE DE GIBI 3 : C CE SOUS PROGRAMME PREPARE LE FICHIER DE SORTIE DE GIBI 4 : C IL COMMENCE PAR EFFACER LES ENREGISTREMENTS DE MEME NOM 5 : C DANS LE FICHIER DE COMMUNICATION (A FAIRE) 6 : C PUIS ECRIT UN ENREGISTREMENT (IMAGE DE CARTES) DONT LE 7 : C NOM EST LE NOM D L'OBJET A PERFORER 8 : C 9 : SUBROUTINE SORTIR(MELEME) 10 : IMPLICIT INTEGER(I-N) 11 : -INC CCOPTIO 12 : -INC SMELEME 13 : -INC CCGEOME 14 : -INC SMCOORD 15 : -INC TMLCHA8 16 : SEGMENT JSGTR(0) 17 : SEGMENT CSGT 18 : CHARACTER*8 CSGTR(0) 19 : ENDSEGMENT 20 : SEGMENT ISGT 21 : INTEGER ISGTR(0) 22 : ENDSEGMENT 23 : SEGMENT ILIST(ILL) 24 : SEGMENT ITLAC(0) 25 : POINTEUR ITLAC1.ITLAC 26 : CHARACTER*8 NOBJ 27 : CHARACTER*(8) CHAR 28 : CHARACTER*4 BLAN 29 : 30 : DATA BLAN /' '/ 31 : 32 : SEGINI ITLAC 32 : CALL QUENOM(NOBJ) 33 : REWIND IOPER 34 : SEGACT MELEME 34 : CALL AJOU(ITLAC,MELEME) 35 : IF(LISOUS(/1).NE.0) THEN 36 : DO 2 I=1,LISOUS(/1) 37 : IVAL=LISOUS(I) 37 : CALL AJOU(ITLAC,IVAL) 38 : 2 CONTINUE 39 : ENDIF 39 : CALL TASSPO(ITLAC,icolac,ipt8,0) 40 : segini,ITLAC1=ITLAC 40 : CALL SUPPIL(ICOLAC,-1) 41 : ITLAC=ITLAC1 42 : segsup ipt8 43 : IF (IERR.NE.0) RETURN 44 : 45 : C LES POINTS SONT CLASSES AVEC EN TETE CEUX DE L'OBJET QUI NOUS 46 : C INTERESSE 47 : C RECHERCHONS LE PLUS GRAND POINT A SORTIR 48 : CG Déja activé.... 49 : CG SEGACT MCOORD 50 : SEGACT MELEME 51 : IMAX=0 52 : DO 5 IK=1,MAX(1,LISOUS(/1)) 53 : IF (LISOUS(/1).NE.0)THEN 54 : IPT1=LISOUS(IK) 55 : SEGACT IPT1 56 : ELSE 57 : IPT1=MELEME 58 : ENDIF 59 : DO 3 J=1,IPT1.NUM(/2) 60 : DO 31 I=1,IPT1.NUM(/1) 61 : IMAX=MAX(IMAX,IPT1.NUM(I,J)) 62 : 31 CONTINUE 63 : 3 CONTINUE 64 : IF (LISOUS(/1).NE.0) SEGDES IPT1 65 : 5 CONTINUE 66 : SEGDES MELEME 67 : C ICI IL FAUDRA RENUMEROTER D'APRES OBJET LES POINTS JUSQU'A IMAX 68 : C ECRITURE DES ENREGISTREMENTS.POSITIONNEMENT A FAIRE QUAND ON SAURA 69 : C COMMENT EST FAIT LE FICHIER 70 : C PREMIER ENREGISTREMENT 71 : 72 : WRITE (IOPER,100) NOBJ,TITREE 73 : 100 FORMAT (A8,A72) 74 : 75 : C DEUXIEME ENREGISTREMENT 76 : IF( IONIVE . EQ. 0 ) WRITE (IOPER,1010) 77 : IF( IONIVE . EQ. 1 ) WRITE (IOPER,1011) 78 : IF( IONIVE . GE. 2 ) WRITE (IOPER,1012) 79 : 1010 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 000 16/01/1983') 80 : 1011 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 001 01/09/1985') 81 : 1012 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 002 29/07/1987') 82 : 83 : C PARAMETRES DU MAILLAGE 84 : WRITE (IOPER,102) IERMAX,IDIM,DENSIT 85 : 102 FORMAT('ERREUR',I4,' DIMENSION',I4,' DENSITE ',1PE12.5) 86 : 87 : C COORDONNEES (IDIM+DENS) 88 : WRITE(IOPER,103) IMAX 89 : 103 FORMAT ('NOMBRE DE POINTS ',I8) 90 : ILONG=(IDIM+1)*IMAX 91 : WRITE (IOPER,104) (XCOOR(I),I=1,ILONG) 92 : 104 FORMAT (1P,6E12.5) 93 : 94 : C CONSTRUCTION DE LA TABLE DES POINTS A PERFORER 95 : SEGINI CSGT,ISGT 95 : CALL REPERT('POINT ',ITITI) 96 : IF(ITITI.NE.0) THEN 96 : CALL REPLIS('POINT ',MLCHA8) 97 : ICO=1 98 : DO 11 I=1,ITITI 98 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 99 : IF(IERR.NE.0) RETURN 100 : IF (IP1.EQ.0) GOTO 11 101 : IF(IP1.GT.IMAX) GOTO 11 102 : ISGTR(**)=IP1 103 : CSGTR(**)=MLCHAR(I) 104 : ICO=ICO+3 105 : 11 CONTINUE 106 : SEGSUP MLCHA8 107 : 12 ENDIF 108 : 109 : C POINTS NOMMES 110 : ILONG=ISGTR(/1) 111 : WRITE (IOPER,105) ILONG 112 : 105 FORMAT('NOMBRE DE POINTS NOMMES',I8) 113 : 114 : IF (ILONG.NE.0) THEN 115 : WRITE (IOPER,106)(CSGTR(I),ISGTR(I),I=1,ILONG) 116 : 106 FORMAT (5(A8,I8)) 117 : 50 ENDIF 118 : 119 : C LISTE DES OBJETS A PERFORER 120 : SEGSUP ISGT,CSGT 121 : SEGINI JSGTR 121 : CALL QUIDAN(JSGTR,ITLAC,IMAX) 122 : SEGSUP ITLAC 123 : 124 : C DANS JSGTR LISTE DES OBJETS A PERFORER 125 : C ON LES PERFORE EN REMPLACANT LES REFERENCES AUX OBJETS POINTES 126 : C ET EN METTANT LE TYPE DE L'ELEMENT EN CLAIR 127 : 128 : ILONG=JSGTR(/1) 129 : WRITE (IOPER,107) ILONG 130 : 107 FORMAT('NOMBRE D''OBJETS ',I8) 131 : 132 : DO 20 I=1,ILONG 133 : MELEME=JSGTR(I) 134 : SEGACT MELEME*MOD 135 : IF (IONIVE.LE.1) THEN 136 : IF (ITYPEL.EQ.0) THEN 137 : WRITE (IOPER,108) BLAN,LISOUS(/1),LISREF(/1),NUM(/1),NUM(/2) 138 : ELSE 139 : WRITE (IOPER,108) NOMS(ITYPEL),LISOUS(/1),LISREF(/1),NUM(/1), 140 : # NUM(/2) 141 : ENDIF 142 : ELSE 143 : IF (ITYPEL.EQ.0) THEN 144 : WRITE (IOPER,1108) BLAN,LISOUS(/1),LISREF(/1),NUM(/1),NUM(/2) 145 : ELSE 146 : WRITE (IOPER,1108) NOMS(ITYPEL),LISOUS(/1),LISREF(/1),NUM(/1), 147 : # NUM(/2) 148 : ENDIF 149 : ENDIF 150 : 108 FORMAT(A4,' SOUS OBJETS',I4,' REFERENCES',I4,' NB NOEUDS',I4, 151 : # ' NB ELEM',I4) 152 : 1108 FORMAT(A4,' SOUS OBJETS',I4,' REFERENCES',I4,' NB NOEUDS',I4, 153 : # ' NBELEM',I5) 154 : 155 : IF (LISOUS(/1).NE.0) THEN 156 : ILL=LISOUS(/1) 157 : SEGINI ILIST 158 : DO 22 J=1,LISOUS(/1) 159 : JOB=LISOUS(J) 160 : DO 23 K=1,JSGTR(/1) 161 : IF (JOB.EQ.JSGTR(K)) GOTO 24 162 : 23 CONTINUE 162 : CALL ERREUR(9) 163 : RETURN 164 : 24 ILIST(J)=K 165 : 22 CONTINUE 166 : WRITE (IOPER,109) (ILIST(L),L=1,ILL) 167 : 109 FORMAT (20I4) 168 : SEGSUP ILIST 169 : 21 ENDIF 170 : 171 : IF (LISREF(/1).NE.0) THEN 172 : ILL=LISREF(/1) 173 : SEGINI ILIST 174 : DO 26 J=1,ILL 175 : JOB=LISREF(J) 176 : DO 27 K=1,JSGTR(/1) 177 : IF (JOB.EQ.JSGTR(K)) GOTO 28 178 : 27 CONTINUE 178 : CALL ERREUR(9) 179 : RETURN 180 : 28 ILIST(J)=K 181 : 26 CONTINUE 182 : WRITE (IOPER,110) (ILIST(L),L=1,ILL) 183 : 110 FORMAT(20I4) 184 : SEGSUP ILIST 185 : 25 ENDIF 186 : 187 : NBNN=NUM(/1) 188 : NBELEM=NUM(/2) 189 : IF (NBNN*NBELEM.EQ.0) GOTO 30 190 : IF (IONIVE.NE.0) THEN 191 : DO 1140 L1= 1,NBELEM 192 : IF(ICOLOR(L1).EQ.0) ICOLOR(L1)=IDCOUL 193 : 1140 CONTINUE 194 : WRITE (IOPER,114) (NCOUL(ICOLOR(L1)),L1=1,NBELEM) 195 : 114 FORMAT (16(1X,A4)) 196 : ENDIF 197 : WRITE (IOPER,111) ((NUM(L1,L2),L1=1,NBNN),L2=1,NBELEM) 198 : 111 FORMAT (16I5) 199 : 30 CONTINUE 200 : SEGDES MELEME 201 : 20 CONTINUE 202 : 203 : C IL NE RESTE PLUS QUE LA LISTE DES NOMS D'OBJETS A SORTIR 204 : 205 : ILL=JSGTR(/1)*3 206 : SEGINI ILIST 207 : ICO=0 207 : CALL REPERT('MAILLAGE',ITITI) 207 : CALL REPLIS('MAILLAGE',MLCHA8) 208 : SEGACT MLCHA8 209 : DO 40 I=1,ITITI 209 : CALL LIROBJ('MAILLAGE',IOB,1,IRETOU) 210 : IF(IERR.NE.0) RETURN 211 : IF (IOB.EQ.0) GOTO 40 212 : DO 41 J=1,JSGTR(/1) 213 : IF (IOB.EQ.JSGTR(J)) GOTO 42 214 : 41 CONTINUE 215 : GOTO 40 216 : 42 CONTINUE 217 : IF (ICO+3.GT.ILIST(/1)) THEN 218 : ILIST(**)=0 219 : ILIST(**)=0 220 : ILIST(**)=0 221 : 43 ENDIF 222 : ICO=ICO+1 223 : READ(MLCHAR(I),FMT='(2A4)')ILIST(ICO),ILIST(ICO+1) 224 : ICO=ICO+2 225 : ILIST(ICO)=J 226 : 40 CONTINUE 227 : 228 : ILONG=ICO/3 229 : WRITE (IOPER,112) ILONG 230 : 112 FORMAT('NOMBRE D''OBJETS NOMMES',I8) 231 : 232 : WRITE (IOPER,113) (ILIST(I),I=1,ICO) 233 : 113 FORMAT (5(2A4,I8)) 234 : 235 : SEGSUP ILIST,JSGTR 236 : RETURN 237 : END 238 : 239 : 240 : 241 : 242 : 243 : 244 : 245 : 246 : 247 : 248 : 249 : 250 : 251 : 252 : 253 :
© Cast3M 2003 - All rights reserved.
Disclaimer