1 : C SAUV SOURCE PV 11/04/08 21:16:43 6934 2 : SUBROUTINE SAUV 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C======================================================================= 6 : C DIRECTIVE SAUVER 7 : C ---------------- 8 : C 9 : C SAUVER (FORMAT) OBJ1 ...OBJN ; 10 : C ($GEO) 11 : C BUT: SAUVEGARDE DES OBJETS NOMMES ET DE CEUX QU ILS 12 : C SOUS-TENDENT, SUR LE FICHIER IOSAU 13 : C IOSAU EST DEFINI PAR: OPTIO SAUV IOSAU ; 14 : C 15 : C 16 : C ON SAIT SAUVER LES OBJETS DONT LE TYPE EST CONTENU 17 : C DANS LE SP TYPFIL 18 : C 19 : C APPELLE TYPFIL CREPIL FILLLU FILLP1 FILLPI SORTRI FILLNO 20 : C MAJICO IMPPIL MAXP1 MAXP32 WRPIL RESTPI SUPPIL 21 : C SAVEPI PILOBJ 22 : C ECRIT PAR FARVACQUE 23 : C REPRIS PAR LENA 24 : C --------------------------------------------------------------------- 25 : C POUR SAUVER UN AUTRE TYPE IL FAUT INTERVENIR DANS TYPFIL: 26 : C RAJOUTER DANS IPOSSI LES DEUX MOTS ASSOCIES 27 : C INCREMENTER NPOSSI DE 2 28 : C VERIFIER QUE LA DIM DU TABLEAU IPOSSI EST GE NPOSSI 29 : C ET FAIRE LE TRAITEMENT DANS CHAQUE SP VIA LES GO TO 30 : C======================================================================= 31 : -INC CCOPTIO 32 : -INC CCNOYAU 33 : -INC TMLCHA8 34 : -INC TMCOLAC 35 : -INC SMCOORD 36 : -INC CCFXDR 37 : -INC CCASSIS 38 : C 39 : SEGMENT ISORTA 40 : CHARACTER*8 ISORTC(KS) 41 : INTEGER ISORTI(KS) 42 : ENDSEGMENT 43 : external long 44 : DIMENSION ITYPE (2) 45 : CHARACTER*(8) CTYP 46 : CHARACTER*4 MOFORM(3) 47 : CHARACTER*72 LABEL 48 : SAVE ILABAU 49 : DATA ILABAU/0/ 50 : DATA MOFORM /'FORM','LABE','MUET'/ 51 : C======================================================================= 52 : C ----ON REGARDE S IL S AGIT D UN SAUV AVEC OU SANS FORMAT----------- 53 : ICOLAC=0 54 : IFORM=0 55 : ISILEN=0 56 : LABEL=' ' 57 : IAUT=1 58 : C * attention aux assistants .... 59 : if (NBESC.NE.0) then 60 : if (iimpi .eq. 1234) 61 : & write(ioimp,*) ' il faut bloquer les assistants' 62 : mestra=imestr 63 : SEGACT MESTRA*MOD 64 : if (iimpi .eq. 1234) 65 : & write(ioimp,*) ' assistants en attente' 66 : * on passe en mode force 66 : call ooofrc(1) 67 : * lodesl=.true. 67 : call setass(1) 68 : endif 69 : 46 CONTINUE 69 : CALL LIRMOT(MOFORM,3,IFURM,0) 70 : IF( IFURM.EQ.1) THEN 71 : IFORM=1 72 : if(isafor.ne.iform) then 72 : call erreur(21) 73 : return 74 : endif 75 : GO TO 46 76 : ELSEIF(IFURM.EQ.2) THEN 76 : CALL LIRCHA (LABEL,1,IRETOU) 77 : IF(IERR.NE.0) RETURN 78 : IAUT=0 79 : GO TO 46 80 : ELSEIF (IFURM.EQ.3) THEN 81 : ISILEN=1 82 : ENDIF 83 : LGEOM=0 84 : iform=isafor 85 : * write (6,*) ' iformx dans sauv ',iformx 86 : if (iformx.eq.2) iform=2 87 : IF(IAUT.EQ.1) THEN 88 : ILABAU=ILABAU+1 89 : LABEL='LABEL_AUTOMATIQUE_' 90 : IF(ilabau.lt.10) then 91 : WRITE(LABEL(19:19),FMT='(I1)') ILABAU 92 : ELSEIF(ilabau.lt.100) then 93 : WRITE(LABEL(19:20),FMT='(I2)') ILABAU 94 : ELSEIF(ilabau.lt.1000) then 95 : WRITE(LABEL(19:21),FMT='(I3)') ILABAU 96 : ELSEIF(ilabau.lt.10000) then 97 : WRITE(LABEL(19:22),FMT='(I4)') ILABAU 98 : ELSE 99 : WRITE(LABEL(19:23),FMT='(I5)') ILABAU 100 : ENDIF 101 : ENDIF 102 : IF (IIMPI.EQ.5) WRITE(IOIMP,799) 103 : 799 FORMAT(' LECTURE DES OBJETS A SAUVER') 104 : 105 : KS=0 106 : SEGINI ISORTA 107 : 108 : 1 CONTINUE 109 : INTEXT=1 110 : CTYP=' ' 110 : CALL QUETYP(CTYP,0,IRETOU) 111 : IF(IRETOU.NE.1) GO TO 100 112 : 112 : CALL LIROBJ(CTYP,IRET,0,IRETOU) 113 : C------- ON CONTROLE LA VALIDITE DU TYPE DEMANDE 114 : K=0 114 : CALL TYPFIL (CTYP,K) 115 : IF (K.LT.0) THEN 116 : C---------- ON NE SAIT PAS SORTIR UN OBJET DE CE TYPE 117 : MOTERR(1:8)=CTYP 117 : CALL ERREUR(242) 118 : GO TO 5000 119 : ENDIF 120 : 121 : C------- LE TYPE EST OK 122 : KS=ISORTI(/1)+1 123 : SEGADJ ISORTA 124 : ISORTC(KS)=CTYP 125 : ISORTI(KS)=IRET 126 : GO TO 1 127 : 128 : C---- ON A EXPLORE TOUTES LES DEMANDES 129 : 100 CONTINUE 130 : LOBJ=ISORTI(/1) 131 : IF (LOBJ.EQ.0) THEN 132 : SEGDES ISORTA 133 : ELSE 134 : IF (IIMPI.EQ.5) WRITE (IOIMP,821) LOBJ 135 : 821 FORMAT(' NOMBRE D OBJETS A SAUVER: ',I5) 136 : ENDIF 137 : 138 : C ------------------------------------------------------- 139 : C **** A PARTIR DES OBJETS DE ISORTA,ON REMPLIT LES PILES 140 : C **** ICOLAC EST INITIALISEE DANS CREPIL 141 : 142 : C---- Cet appel a TYPFIL renvoie -NPOSSI dans K 143 : CTYP=' ' 144 : K=-1 144 : CALL TYPFIL( CTYP,K) 145 : C---- NITLAC = nombre de types 'sauvegardables' 146 : NITLAC=-K 147 : IF(IPSAUV.NE.0) THEN 148 : ICOLAC=IPSAUV 148 : CALL CREPI0(ICOLAC) 149 : segact icolac*mod 150 : iform=ifform 151 : ELSE 151 : CALL CREPIL(ICOLAC,NITLAC) 152 : segact icolac*mod 153 : IFFORM=IFORM 154 : ENDIF 155 : C---- Cet appel cree un 1 segment ICOLAC(NITLAC) ainsi que NITLAC : 156 : C - segments ITLACC dont les adresses sont stockees dans KCOLA 157 : C (faisant partie de ICOLAC) 158 : C - segments ISGTR(KS) avec KS=0 dont les adresses sont stockees 159 : C dans ICOLA (faisant partie de ICOLAC) 160 : C Les MCOLA et KCOLAC sont initialises a 0. A la fin ICOLAC est desactive. 161 : 162 : IF (IIMPI.EQ.5) WRITE (IOIMP,801) NITLAC 163 : 801 FORMAT(' NOMBRE DE PILES CREEES : ',I5) 164 : C 165 : C on met la configuration courante dans la pile si pas deja 166 : C 167 : SEGACT ICOLAC 168 : ILISSE=ILISSG 169 : SEGACT ILISSE*MOD 170 : ITLACC=KCOLA(33) 171 : SEGACT ITLACC*MOD 172 : ICFCO= MCOORD 172 : CALL AJOUN(ITLACC,ICFCO,ILISSE,1) 173 : C --- REMPLISSAGE DES PILES A PARTIR DES DEMANDES 174 : 175 : IF (LOBJ.EQ.0) THEN 176 : C ------ PAS D OBJETS NOMMES : ON SAUVE TOUT 176 : CALL LISTYP (MLCHA8) 176 : CALL FILLPO (ICOLAC,MLCHA8) 177 : SEGSUP MLCHA8 178 : ELSE 178 : CALL FILLLU(ISORTA,ICOLAC) 179 : ENDIF 180 : SEGSUP ISORTA 181 : CMB-- Maintenant ICOLAC contient la liste des objets a sauvegarder 182 : 183 : C---- PETITE MAGOUILLE POUR LES OBJETS RIGIDITES 184 : C ET LES SUPER ELEMENTS 184 : CALL SORTRI(ICOLAC) 185 : C --- IER PASSAGE POUR COMPLETER LES PILES SANS CHANGER LES POINTEURS 185 : CALL FILLPI (ICOLAC) 186 : 187 : IF (IIMPI.EQ.5)WRITE (IOIMP,802) 188 : 802 FORMAT(' PREMIER REMPLISSAGE DES PILES EFFECTUE') 189 : 190 : C --- ON CHERCHE A COMPLETER LES CHAPEAUX DE CERTAINS OBJETS 190 : CALL HATRIG (ICOLAC) 190 : CALL HATSTR (ICOLAC) 191 : * 192 : * IL FAUT REAPPELLER SORTRI POUR LA PETITE MAGOUILLE 193 : * POUR LES EVENTUELLES RIGIDITES AJOUTEES PAR HATRIG 194 : C----PETITE MAGOUILLE POUR LES OBJETS RIGIDITES 195 : C ET LES SUPER ELEMENTS 195 : CALL SORTRI(ICOLAC) 196 : * 197 : C --- MISE A JOUR DU KCOLAC 197 : C CALL MAJICO (ICOLAC) 198 : C --- RECHERCHE DU NUMERO MAX DE POINT A PARTIR DE L ETAT 199 : C DES PILES 1 ET 32 199 : CALL MAXP1 (ICOLAC,IMAX) 199 : CALL MAXP32 (ICOLAC,I32MAX) 200 : IMAX= MAX(IMAX,I32MAX) 201 : C --- ON COMPLETE EVENTUELLEMENT LA PILE 1 A PARTIR DE TOUS LES OBJETS 202 : C MAILLAGE DONT LES NOEUDS SONT INFERIEURS A IMAX 203 : IIICHA=0 203 : CALL FILLP1 (ICOLAC,IMAX) 204 : C --- 2IEME PASSAGE SANS CHANGER LES POINTEURS 205 : C BECAUSE DES MELEME NOUVEAUX 205 : CALL FILLPI (ICOLAC) 206 : 207 : IF (IIMPI.EQ.5)WRITE (IOIMP,803) 208 : 803 FORMAT(' SECOND REMPLISSAGE DES PILES EFFECTUE') 209 : 210 : C --- MISE A JOUR DU KCOLAC 210 : C CALL MAJICO (ICOLAC) 211 : IF(IERR.NE.0) GOTO 5000 212 : C ------------------------------------------------------- 213 : C --- RECHERCHE DES NOMS 213 : CALL FILLNO (ICOLAC) 214 : 215 : C --- IMPRESSIONS INTERMEDIAIRES DES PILES 216 : IVOULU=0 216 : IF(IIMPI.EQ.6) CALL IMPPIL (ICOLAC,IVOULU) 217 : 218 : C --- 3IEME PASSAGE CHANGEMENT DES POINTEURS 218 : CALL SAVEPI (ICOLAC) 219 : IF (IIMPI.EQ.5)WRITE (IOIMP,804) 220 : 804 FORMAT(' CHANGEMENT DES POINTEURS EFFECTUE ') 221 : C 222 : C-------------------------------------------------------- 223 : C **** ECRITURE SUR LE FICHIER DE SORTIE 224 : C --- ECRITURE DES PILES 225 : C REWIND IOSAU 225 : CALL WRPIL (ICOLAC,IMAX,IFORM,LABEL,ISILEN) 226 : 227 : IF (IIMPI.EQ.5) WRITE (IOIMP,805) 228 : 805 FORMAT(' SAUVETAGE EFFECTUE ') 229 : 230 : C --- RESTAURATION DES POINTEURS 230 : CALL RESTPI (ICOLAC) 231 : 232 : IF (IIMPI.EQ.5)WRITE (IOIMP,806) 233 : 806 FORMAT(' RESTAURATION DES POINTEURS EFFECTUEE ') 234 : C------------------------------------------------------------- 235 : C --- SUPPRESSION DES PILES (IVOULU=0) 236 : IVOULU=0 236 : CALL SUPPIL (ICOLAC,IVOULU) 237 : IF (IIMPI.EQ.5) WRITE (IOIMP,807) 238 : 807 FORMAT(' SUPPRESSION DES PILES EFFECTUEE ') 239 : 239 : CALL ERREUR(-276) 240 : C MODI N.BLAY LE 17/09/91 POUR VIDER LES BUFFERS.------------- 241 : C REWIND IOSAU 242 : if (iform.eq.2) then 243 : ios=IXDRCLOSE( ixdrw,.TRUE. ) 244 : ios= initxdr(NOMFIC(1:long(nomfic)),'a',.TRUE.) 245 : endif 246 : C * attention aux assistants .... 247 : if (NBESC.NE.0) then 248 : C * il faut liberer le segment de dialogue 249 : mestra=imestr 250 : * repasser en mode normal 250 : call ooofrc(0) 251 : SEGDES MESTRA 252 : * lodesl=.false. 252 : call setass(0) 253 : end if 254 : GO TO 11 255 : 5000 CONTINUE 255 : CALL ERREUR(558) 256 : 257 : 11 RETURN 258 : END 259 : 260 : 261 : 262 :
© Cast3M 2003 - All rights reserved.
Disclaimer