Sources Esope | Cast3M

sauv
C SAUV      SOURCE    FANDEUR   22/03/10    21:15:04     11313          
      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 PPARAM
-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'/
      iun=1
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---- 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  **** 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=ILISSP
      SEGACT ILISSE*MOD
      ILISSE=ILISSG
      SEGACT ILISSE*MOD
      ITLACC=KCOLA(33)
      SEGACT ITLACC*MOD
      ICFCO= MCOORD
      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---- 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
         if (ixdrw.ne.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
*         write (ioimp,*) ' sauv reouverture de ',NOMSAU
         ios= initxdr(NOMSAU(1:long(NOMSAU)),'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
      RETURN
 
 5000 CONTINUE
      CALL ERREUR(558)
      RETURN
 
      END