Sources Esope | Cast3M

wrmtak
C WRMTAK    SOURCE    PV        17/12/05    21:17:29     9646           
      SUBROUTINE WRMTAK(IFSAU,ITLACC,IMAX1,IFORM,IDEB)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C***********************************************************************
C NOM         : WRMTAK
C DESCRIPTION : Ecriture des objets de type MATRAK sur le
C               fichier IFSAU
C               (appelé par wrpil.eso)
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES (E/S)    : ECDIFE (ecriture d'un tableau d'entiers)
C                    ECDIFR (ecriture d'un tableau de REAL*8)
C***********************************************************************
C SYNTAXE GIBIANE    : SAUV
C ENTREES            : IFSAU, numéro du fichier en écriture
C                      IDEB, IMAX1, indice de début et de fin
C                      de la pile des objets MATRAK (ITLACC)
C                      à écrire.
C                      IFORM, le fichier a ecrire est formaté ou
C                             non.
C***********************************************************************
C VERSION    : v1, 15/07/98, version initiale
C HISTORIQUE : v1, 15/07/98, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
C-INC SMMATRAKANC
C*************************************************************************
C
C    REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES  puis assemblees
C
 
* LGEOC SPG de la pression et/ou des multiplicateurs de Lagrange
* (points CENTRE ) pour chaque operateur de contrainte
* KGEOC SPG pour la totalite des points CENTRE.
* KGEOS SPG pour la totalite des points SOMMET (Diagonale vitesse)
* KLEMC Connectivites de l'ensemble des contraintes
* LIZAFM(NBSOUS) contient les pointeurs IZAFM des sous-zones
 
      SEGMENT MATRAK
      INTEGER LGEOC(NBOP),IDEBS(NBOP),IFINS(NBOP)
      INTEGER LIZAFM(NBSOUS)
      INTEGER IKAM0 (NBSOUS)
      INTEGER IMEM  (NBELC)
      INTEGER KLEMC,KGEOS,KGEOC,KDIAG,KCAC,KIZCL,KIZGC
      ENDSEGMENT
 
      SEGMENT IZAFM
      REAL*8  AM(NNELP,NP,IESP),RPGI(NELAX)
      ENDSEGMENT
C*************************************************************************
-INC SMMATRK1
-INC TMCOLAC
      SEGMENT IZA
      REAL*8 A(NBVA)
      ENDSEGMENT
C
      INTEGER NDTAB
      INTEGER IEL,I
      INTEGER ILENA(7)
C======================================================================
*
* Executable statements
*
C
C ... BOUCLE SUR LES MATRAK DE LA PILE
      DO 1 IEL=IDEB,IMAX1
         MATRAK=ITLAC(IEL)
         IF (MATRAK.EQ.0) THEN
            WRITE(IOIMP,*) 'Failing to save a nil pointer'
            WRITE(IOIMP,*) 'MATRAK type object...'
            GOTO 9999
         ENDIF
C     Sauvegarde du chapeau
C       Dimensions
         SEGACT MATRAK
         NBOP  =LGEOC(/1)
         NBSOUS=LIZAFM(/1)
         NBELC =IMEM(/1)
         ILENA(1)=NBOP
         ILENA(2)=NBSOUS
         ILENA(3)=NBELC
         NDTAB=3
         CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
C       Rigidités élémentaires
         NDTAB=NBOP
         CALL ECDIFE(IFSAU,NDTAB,LGEOC,IFORM)
         NDTAB=NBOP
         CALL ECDIFE(IFSAU,NDTAB,IDEBS,IFORM)
         NDTAB=NBOP
         CALL ECDIFE(IFSAU,NDTAB,IFINS,IFORM)
         NDTAB=NBSOUS
         CALL ECDIFE(IFSAU,NDTAB,LIZAFM,IFORM)
         NDTAB=NBSOUS
         CALL ECDIFE(IFSAU,NDTAB,IKAM0,IFORM)
         NDTAB=NBELC
         CALL ECDIFE(IFSAU,NDTAB,IMEM,IFORM)
         ILENA( 1)=KLEMC
         ILENA( 2)=KGEOS
         ILENA( 3)=KGEOC
         ILENA( 4)=KDIAG
         ILENA( 5)=KCAC
         ILENA( 6)=KIZCL
         ILENA( 7)=KIZGC
         NDTAB=7
         CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
C     Sauvegarde des IZAFM
         DO 11 I=1,NBSOUS
            IZAFM=LIZAFM(I)
            IF (IZAFM.NE.0) THEN
               SEGACT IZAFM
               NNELP=AM(/1)
               NP   =AM(/2)
               IESP =AM(/3)
               NELAX=RPGI(/1)
               ILENA(1)=NNELP
               ILENA(2)=NP
               ILENA(3)=IESP
               ILENA(4)=NELAX
               NDTAB=4
               CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
               NDTAB=NNELP*NP*IESP
               CALL ECDIFR(IFSAU,NDTAB,AM,IFORM)
               NDTAB=NELAX
               CALL ECDIFR(IFSAU,NDTAB,RPGI,IFORM)
               SEGDES IZAFM
            ENDIF
 11      CONTINUE
C     Sauvegarde du IZL
         IF (KIZCL.NE.0) THEN
            IZL=KIZCL
            SEGACT IZL
C       Dimensions
            NJA=KZA(/1)
            NJAN=NUAN(/1)
            NJAB=B(/1)
            ILENA(1)=NJA
            ILENA(2)=NJAN
            ILENA(3)=NJAB
            ILENA(4)=KZA1
            NDTAB=4
            CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
C       Contenu des tableaux
            NDTAB=NJA
            CALL ECDIFE(IFSAU,NDTAB,KZA,IFORM)
            NDTAB=NJAN
            CALL ECDIFE(IFSAU,NDTAB,NUAN,IFORM)
            NDTAB=NJAN
            CALL ECDIFE(IFSAU,NDTAB,NUNA,IFORM)
            NDTAB=NJAN
            CALL ECDIFE(IFSAU,NDTAB,IMEL,IFORM)
            NDTAB=NJAN
            CALL ECDIFE(IFSAU,NDTAB,IMJ,IFORM)
            NDTAB=NJAB
            CALL ECDIFR(IFSAU,NDTAB,B,IFORM)
C       Sauvegarde du IDMAT
            IF (KZA1.NE.0) THEN
               IDMAT=KZA1
               SEGACT IDMAT
C         Dimension
               NBLK=IDESCR(/1)
               ILENA(1)=NBLK
               ILENA(2)=IDIAG
               NDTAB=2
               CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
               NDTAB=NBLK
               CALL ECDIFE(IFSAU,NDTAB,IDESCR,IFORM)
               NDTAB=NBLK+1
               CALL ECDIFE(IFSAU,NDTAB,NLDBLK,IFORM)
               IF (IDIAG.NE.0) THEN
                  IZA=IDIAG
                  SEGACT IZA
                  NBVA=A(/1)
                  ILENA(1)=NBVA
                  NDTAB=1
                  CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
                  NDTAB=NBVA
                  CALL ECDIFR(IFSAU,NDTAB,A,IFORM)
                  SEGDES IZA
               ENDIF
C        Sauvegarde des IDBLK
               DO 211 INBLK=1,NBLK
                  IDBLK=IDESCR(INBLK)
                  IF (IDBLK.NE.0) THEN
                     SEGACT IDBLK
C           Dimension
                     NLBLK=IDEBLK(/1)-1
                     ILENA(1)=NLBLK
                     ILENA(2)=IMAT
                     ILENA(3)=ILON
                     NDTAB=3
                     CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
                     NDTAB=NLBLK+1
                     CALL ECDIFE(IFSAU,NDTAB,IDEBLK,IFORM)
                     IF (IMAT.NE.0) THEN
                        IZA=IMAT
                        SEGACT IZA
                        NBVA=A(/1)
                        ILENA(1)=NBVA
                        NDTAB=1
                        CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
                        NDTAB=NBVA
                        CALL ECDIFR(IFSAU,NDTAB,A,IFORM)
                        SEGDES IZA
                     ENDIF
                     SEGDES IDBLK
                  ENDIF
 211           CONTINUE
               SEGDES IDMAT
            ENDIF
            SEGDES IZL
         ENDIF
         SEGDES MATRAK
 1    CONTINUE
*
* Normal termination
*
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      WRITE(IOIMP,*) 'An error was detected in subroutine wrmtak'
      RETURN
*
* End of subroutine WRMTIK
*
      END