C SAUV SOURCE SP204843 26/02/03 21:15:38 12461 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 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 IMPPIL MAXP1 MAXP32 WRPIL RESTPI SUPPIL SAVEPI C 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======================================================================= SUBROUTINE SAUV IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCNOYAU -INC CCFXDR -INC CCASSIS -INC SMCOORD -INC SMLENTI -INC TMLCHA8 -INC TMCOLAC SEGMENT ISORTA CHARACTER*8 ISORTC(KS) INTEGER ISORTI(KS) ENDSEGMENT EXTERNAL LONG CHARACTER*(8) CTYP CHARACTER*4 MOFORM(3) CHARACTER*72 LABEL SAVE ILABAU DATA ILABAU/0/ DATA MOFORM /'FORM','LABE','MUET'/ iun=1 iimpil = IIMPI C --- NIVEAU MAXIMAL COURANT : IONIVR (voir REST lipil.eso) IONIVR = 28 IONIVS = IONIVE C --- NIVEAU DE SAUVEGARDE ACTUEL (si 0 -> niveau MAXIMAL) NIVEAU = IONIVE IF (NIVEAU.EQ.0) NIVEAU = IONIVR C --- VERIFICATIONS SUR LE NIVEAU DE SAUVEGARDE DEMANDE IF (NIVEAU.LT.1 .OR. NIVEAU.GT.IONIVR) THEN INTERR(1) = NIVEAU INTERR(2) = 1 INTERR(3) = IONIVR CALL ERREUR(1068) RETURN ENDIF C --- NIVEAU DE SAUVEGARDE CHOISI IONIVE = NIVEAU C---- LE NIVEAU 22 A INTRODUIT LES NOMS DE PLUS DE 8 CARACTERES IF (IONIVE.LT.22) THEN INTERR(1)=IONIVE CALL ERREUR(-359) ENDIF C======================================================================= C * attention aux assistants .... if (NBESC.NE.0) then if (iimpil.eq.1234) & write(ioimp,*) ' il faut bloquer les assistants' mestra=imestr SEGACT MESTRA*MOD if (iimpil.eq.1234) & write(ioimp,*) ' assistants en attente' * on passe en mode force call ooofrc(1) * lodesl=.true. call setass(1) endif C======================================================================= C ---- LECTURE DES MOTS-CLES : AVEC OU SANS FORMAT----------- IFORM = 0 ISILE = 0 IAUTO = 1 LABEL = ' ' 46 CONTINUE CALL LIRMOT(MOFORM,3,IFURM,0) IF (IERR.NE.0) GOTO 5000 IF (IFURM.EQ.1) THEN IFORM=1 if (isafor.ne.iform) then call erreur(21) goto 5000 endif GO TO 46 ELSEIF (IFURM.EQ.2) THEN CALL LIRCHA(LABEL,1,IRETOU) IF (IERR.NE.0) GOTO 5000 IAUTO=0 GO TO 46 ELSEIF (IFURM.EQ.3) THEN ISILE=1 GO TO 46 ENDIF iform = isafor * write (6,*) ' iformx dans sauv ',iformx if (iformx.eq.2) iform = 2 C======================================================================= IF (IAUTO.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 (iimpil.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 (IERR.NE.0) RETURN IF (IRETOU.NE.1) GOTO 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 c** SEGDES ISORTA ELSE IF (iimpil.EQ.5) WRITE (IOIMP,821) LOBJ 821 FORMAT(' NOMBRE D OBJETS A SAUVER : ',I6) ENDIF C --------------------------------------------------------- C **** A PARTIR DES OBJETS DE ISORTA, ON REMPLIT LES PILES C **** ICOLAC EST INITIALISEE DANS CREPIL ICOLAC=0 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 = icolac.IFFORM ELSE CALL CREPIL(ICOLAC,NITLAC) SEGACT ICOLAC*MOD icolac.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 (iimpil.EQ.5) WRITE(IOIMP,801) NITLAC 801 FORMAT(' NOMBRE DE PILES CREEES : ',I5) SEGACT ICOLAC ILISSE=ILISSP SEGACT ILISSE*MOD ILISSE=ILISSG SEGACT ILISSE*MOD C C on met la configuration courante dans la pile si pas deja C ITLACC=KCOLA(33) c* SEGACT ITLACC*MOD <- Fait dans AJOUN ICFCO= MCOORD ** write(6,*) 'configuration courante dans sauv',icfco CALL AJOUN(ITLACC,ICFCO,ILISSE,iun) 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 --- FORMULATION HHO : Initialisations/Verifications -------- CALL HHOPIL(1,IONIVE,iun) C---- PETITE MAGOUILLE POUR LES OBJETS RIGIDITES ET LES SUPER ELEMENTS CALL SORTRI(ICOLAC) C --- IER PASSAGE POUR COMPLETER LES PILES SANS CHANGER LES POINTEURS CALL FILLPI(ICOLAC) IF (iimpil.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 ET LES SUPER ELEMENTS CALL SORTRI(ICOLAC) C --- RECHERCHE DU NUMERO MAX DE POINT A PARTIR DE L ETAT 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 CALL FILLP1(ICOLAC,IMAX) C --- 2EME PASSAGE SANS CHANGER LES POINTEURS SUITE A AJOUT MELEME NOUVEAUX CALL FILLPI(ICOLAC) IF (iimpil.EQ.5) WRITE (IOIMP,803) 803 FORMAT(' SECOND REMPLISSAGE DES PILES EFFECTUE') IF (IERR.NE.0) THEN CALL ERREUR(558) GOTO 5000 ENDIF C ------------------------------------------------------- C --- RECHERCHE DES NOMS CALL FILLNO (ICOLAC) C --- IMPRESSIONS INTERMEDIAIRES DES PILES IVOULU=0 IF (iimpil.EQ.5) CALL IMPPIL(ICOLAC,IVOULU) C --- 3EME PASSAGE CHANGEMENT DES POINTEURS CALL SAVEPI (ICOLAC) IF (iimpil.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,ISILE) IF (iimpil.EQ.5) WRITE(IOIMP,805) 805 FORMAT(' SAUVEGARDE EFFECTUEE') C --- RESTAURATION DES POINTEURS CALL RESTPI(ICOLAC) IF (iimpil.EQ.5) WRITE(IOIMP,806) 806 FORMAT(' RESTAURATION DES POINTEURS EFFECTUEE') C------------------------------------------------------------- C --- SUPPRESSION DES PILES (IVOULU=0) IVOULU=0 CALL SUPPIL(ICOLAC,IVOULU) C --- FORMULATION HHO : MENAGE ------------------------------- CALL HHOPIL(9,iun,iun) IF (iimpil.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 if (ixdrw.ne.0) ios=IXDRCLOSE( ixdrw,.TRUE. ) * write (ioimp,*) ' sauv reouverture de ',NOMSAU ios = initxdr(NOMSAU(1:long(NOMSAU)),'a',.TRUE.) endif 5000 CONTINUE 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 IONIVE = IONIVS RETURN END