C SAUV SOURCE PV 11/04/08 21:16:43 6934 SUBROUTINE SAUV IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C======================================================================= C DIRECTIVE SAUVER C ---------------- C C SAUVER (FORMAT) OBJ1 ...OBJN ; C ($GEO) C BUT: SAUVEGARDE DES OBJETS NOMMES ET DE CEUX QU ILS C SOUS-TENDENT, SUR LE FICHIER IOSAU C IOSAU EST DEFINI PAR: OPTIO SAUV IOSAU ; C C C ON SAIT SAUVER LES OBJETS DONT LE TYPE EST CONTENU C DANS LE SP TYPFIL C C APPELLE TYPFIL CREPIL FILLLU FILLP1 FILLPI SORTRI FILLNO C MAJICO IMPPIL MAXP1 MAXP32 WRPIL RESTPI SUPPIL C SAVEPI PILOBJ C ECRIT PAR FARVACQUE C REPRIS PAR LENA C --------------------------------------------------------------------- C POUR SAUVER UN AUTRE TYPE IL FAUT INTERVENIR DANS TYPFIL: C RAJOUTER DANS IPOSSI LES DEUX MOTS ASSOCIES C INCREMENTER NPOSSI DE 2 C VERIFIER QUE LA DIM DU TABLEAU IPOSSI EST GE NPOSSI C ET FAIRE LE TRAITEMENT DANS CHAQUE SP VIA LES GO TO C======================================================================= -INC CCOPTIO -INC CCNOYAU -INC TMLCHA8 -INC TMCOLAC -INC SMCOORD -INC CCFXDR -INC CCASSIS C SEGMENT ISORTA CHARACTER*8 ISORTC(KS) INTEGER ISORTI(KS) ENDSEGMENT external long DIMENSION ITYPE (2) CHARACTER*(8) CTYP CHARACTER*4 MOFORM(3) CHARACTER*72 LABEL SAVE ILABAU DATA ILABAU/0/ DATA MOFORM /'FORM','LABE','MUET'/ C======================================================================= C ----ON REGARDE S IL S AGIT D UN SAUV AVEC OU SANS FORMAT----------- ICOLAC=0 IFORM=0 ISILEN=0 LABEL=' ' IAUT=1 C * attention aux assistants .... if (NBESC.NE.0) then if (iimpi .eq. 1234) & write(ioimp,*) ' il faut bloquer les assistants' mestra=imestr SEGACT MESTRA*MOD if (iimpi .eq. 1234) & write(ioimp,*) ' assistants en attente' * on passe en mode force call ooofrc(1) * lodesl=.true. call setass(1) endif 46 CONTINUE CALL LIRMOT(MOFORM,3,IFURM,0) IF( IFURM.EQ.1) THEN IFORM=1 if(isafor.ne.iform) then call erreur(21) return endif GO TO 46 ELSEIF(IFURM.EQ.2) THEN CALL LIRCHA (LABEL,1,IRETOU) IF(IERR.NE.0) RETURN IAUT=0 GO TO 46 ELSEIF (IFURM.EQ.3) THEN ISILEN=1 ENDIF LGEOM=0 iform=isafor * write (6,*) ' iformx dans sauv ',iformx if (iformx.eq.2) iform=2 IF(IAUT.EQ.1) THEN ILABAU=ILABAU+1 LABEL='LABEL_AUTOMATIQUE_' IF(ilabau.lt.10) then WRITE(LABEL(19:19),FMT='(I1)') ILABAU ELSEIF(ilabau.lt.100) then WRITE(LABEL(19:20),FMT='(I2)') ILABAU ELSEIF(ilabau.lt.1000) then WRITE(LABEL(19:21),FMT='(I3)') ILABAU ELSEIF(ilabau.lt.10000) then WRITE(LABEL(19:22),FMT='(I4)') ILABAU ELSE WRITE(LABEL(19:23),FMT='(I5)') ILABAU ENDIF ENDIF IF (IIMPI.EQ.5) WRITE(IOIMP,799) 799 FORMAT(' LECTURE DES OBJETS A SAUVER') KS=0 SEGINI ISORTA 1 CONTINUE INTEXT=1 CTYP=' ' CALL QUETYP(CTYP,0,IRETOU) IF(IRETOU.NE.1) GO TO 100 CALL LIROBJ(CTYP,IRET,0,IRETOU) C------- ON CONTROLE LA VALIDITE DU TYPE DEMANDE K=0 CALL TYPFIL (CTYP,K) IF (K.LT.0) THEN C---------- ON NE SAIT PAS SORTIR UN OBJET DE CE TYPE MOTERR(1:8)=CTYP CALL ERREUR(242) GO TO 5000 ENDIF C------- LE TYPE EST OK KS=ISORTI(/1)+1 SEGADJ ISORTA ISORTC(KS)=CTYP ISORTI(KS)=IRET GO TO 1 C---- ON A EXPLORE TOUTES LES DEMANDES 100 CONTINUE LOBJ=ISORTI(/1) IF (LOBJ.EQ.0) THEN SEGDES ISORTA ELSE IF (IIMPI.EQ.5) WRITE (IOIMP,821) LOBJ 821 FORMAT(' NOMBRE D OBJETS A SAUVER: ',I5) ENDIF C ------------------------------------------------------- C **** A PARTIR DES OBJETS DE ISORTA,ON REMPLIT LES PILES C **** ICOLAC EST INITIALISEE DANS CREPIL C---- Cet appel a TYPFIL renvoie -NPOSSI dans K CTYP=' ' K=-1 CALL TYPFIL( CTYP,K) C---- NITLAC = nombre de types 'sauvegardables' NITLAC=-K IF(IPSAUV.NE.0) THEN ICOLAC=IPSAUV CALL CREPI0(ICOLAC) segact icolac*mod iform=ifform ELSE CALL CREPIL(ICOLAC,NITLAC) segact icolac*mod IFFORM=IFORM ENDIF C---- Cet appel cree un 1 segment ICOLAC(NITLAC) ainsi que NITLAC : C - segments ITLACC dont les adresses sont stockees dans KCOLA C (faisant partie de ICOLAC) C - segments ISGTR(KS) avec KS=0 dont les adresses sont stockees C dans ICOLA (faisant partie de ICOLAC) C Les MCOLA et KCOLAC sont initialises a 0. A la fin ICOLAC est desactive. IF (IIMPI.EQ.5) WRITE (IOIMP,801) NITLAC 801 FORMAT(' NOMBRE DE PILES CREEES : ',I5) C C on met la configuration courante dans la pile si pas deja C SEGACT ICOLAC ILISSE=ILISSG SEGACT ILISSE*MOD ITLACC=KCOLA(33) SEGACT ITLACC*MOD ICFCO= MCOORD CALL AJOUN(ITLACC,ICFCO,ILISSE,1) C --- REMPLISSAGE DES PILES A PARTIR DES DEMANDES IF (LOBJ.EQ.0) THEN C ------ PAS D OBJETS NOMMES : ON SAUVE TOUT CALL LISTYP (MLCHA8) CALL FILLPO (ICOLAC,MLCHA8) SEGSUP MLCHA8 ELSE CALL FILLLU(ISORTA,ICOLAC) ENDIF SEGSUP ISORTA CMB-- Maintenant ICOLAC contient la liste des objets a sauvegarder C---- PETITE MAGOUILLE POUR LES OBJETS RIGIDITES C ET LES SUPER ELEMENTS CALL SORTRI(ICOLAC) C --- IER PASSAGE POUR COMPLETER LES PILES SANS CHANGER LES POINTEURS CALL FILLPI (ICOLAC) IF (IIMPI.EQ.5)WRITE (IOIMP,802) 802 FORMAT(' PREMIER REMPLISSAGE DES PILES EFFECTUE') C --- ON CHERCHE A COMPLETER LES CHAPEAUX DE CERTAINS OBJETS CALL HATRIG (ICOLAC) CALL HATSTR (ICOLAC) * * IL FAUT REAPPELLER SORTRI POUR LA PETITE MAGOUILLE * POUR LES EVENTUELLES RIGIDITES AJOUTEES PAR HATRIG C----PETITE MAGOUILLE POUR LES OBJETS RIGIDITES C ET LES SUPER ELEMENTS CALL SORTRI(ICOLAC) * C --- MISE A JOUR DU KCOLAC C CALL MAJICO (ICOLAC) C --- RECHERCHE DU NUMERO MAX DE POINT A PARTIR DE L ETAT C DES PILES 1 ET 32 CALL MAXP1 (ICOLAC,IMAX) CALL MAXP32 (ICOLAC,I32MAX) IMAX= MAX(IMAX,I32MAX) C --- ON COMPLETE EVENTUELLEMENT LA PILE 1 A PARTIR DE TOUS LES OBJETS C MAILLAGE DONT LES NOEUDS SONT INFERIEURS A IMAX IIICHA=0 CALL FILLP1 (ICOLAC,IMAX) C --- 2IEME PASSAGE SANS CHANGER LES POINTEURS C BECAUSE DES MELEME NOUVEAUX CALL FILLPI (ICOLAC) IF (IIMPI.EQ.5)WRITE (IOIMP,803) 803 FORMAT(' SECOND REMPLISSAGE DES PILES EFFECTUE') C --- MISE A JOUR DU KCOLAC C CALL MAJICO (ICOLAC) IF(IERR.NE.0) GOTO 5000 C ------------------------------------------------------- C --- RECHERCHE DES NOMS CALL FILLNO (ICOLAC) C --- IMPRESSIONS INTERMEDIAIRES DES PILES IVOULU=0 IF(IIMPI.EQ.6) CALL IMPPIL (ICOLAC,IVOULU) C --- 3IEME PASSAGE CHANGEMENT DES POINTEURS CALL SAVEPI (ICOLAC) IF (IIMPI.EQ.5)WRITE (IOIMP,804) 804 FORMAT(' CHANGEMENT DES POINTEURS EFFECTUE ') C C-------------------------------------------------------- C **** ECRITURE SUR LE FICHIER DE SORTIE C --- ECRITURE DES PILES C REWIND IOSAU CALL WRPIL (ICOLAC,IMAX,IFORM,LABEL,ISILEN) IF (IIMPI.EQ.5) WRITE (IOIMP,805) 805 FORMAT(' SAUVETAGE EFFECTUE ') C --- RESTAURATION DES POINTEURS CALL RESTPI (ICOLAC) IF (IIMPI.EQ.5)WRITE (IOIMP,806) 806 FORMAT(' RESTAURATION DES POINTEURS EFFECTUEE ') C------------------------------------------------------------- C --- SUPPRESSION DES PILES (IVOULU=0) IVOULU=0 CALL SUPPIL (ICOLAC,IVOULU) IF (IIMPI.EQ.5) WRITE (IOIMP,807) 807 FORMAT(' SUPPRESSION DES PILES EFFECTUEE ') CALL ERREUR(-276) C MODI N.BLAY LE 17/09/91 POUR VIDER LES BUFFERS.------------- C REWIND IOSAU if (iform.eq.2) then ios=IXDRCLOSE( ixdrw,.TRUE. ) ios= initxdr(NOMFIC(1:long(nomfic)),'a',.TRUE.) endif C * attention aux assistants .... if (NBESC.NE.0) then C * il faut liberer le segment de dialogue mestra=imestr * repasser en mode normal call ooofrc(0) SEGDES MESTRA * lodesl=.false. call setass(0) end if GO TO 11 5000 CONTINUE CALL ERREUR(558) 11 RETURN END