Sources Esope | Cast3M

sauv
C SAUV      SOURCE    PV090527  25/01/07    18:18:28     12116          
 
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 = 26
      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 &lt;- 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