Sources Esope | Cast3M

wrcham
C WRCHAM    SOURCE    CB215821  20/11/04    21:22:18     10766          
      SUBROUTINE WRCHAM(IOSAU,ITLACC,IMAX1,IFORM,IONIVE,IDEB)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*--------------------------------------------------------------------*
*                                                                    *
*     Ecriture d'un nouveau CHAMELEM sur le fichier IOSAU.           *
*                                                                    *
*     Paramètres:                                                    *
*                                                                    *
*     IOSAU   Numéro du fichier de sortie                            *
*     ITLACC  Pile contenant les nouveaux CHAMELEMs                  *
*     IMAX1   Nombre de CHAMELEMs dans la pile                       *
*     IFORM   Si sauvegarde en format ou non                         *
*                                                                    *
*     Appelé par: WRPIL                                              *
*                                                                    *
*     Auteur, date de création:                                      *
*                                                                    *
*     Denis ROBERT-MOUGIN, le 29 juin 1989.                          *
*     ANNEE DU BICENTENAIRE DE LA REVOLUTION FRANCAISE               *
*                                                                    *
*--------------------------------------------------------------------*
-INC PPARAM
-INC SMCHAML
-INC CCFXDR
*
      SEGMENT,ITLACC
         INTEGER ITLAC(0)
      ENDSEGMENT
      SEGMENT,MTABE1
         INTEGER ITABE1(NM1)
      ENDSEGMENT
      SEGMENT,MTABE2
         INTEGER ITABE2(NM2)
      ENDSEGMENT
      SEGMENT,MTABE3
        CHARACTER*(8) ITABE3(NM2)
      ENDSEGMENT
      SEGMENT,MTABE4
        CHARACTER*(8) ITABE4(NM4)
      ENDSEGMENT
      SEGMENT,MTABE5
        CHARACTER*(8) ITABE5(NM5)
      ENDSEGMENT
      SEGMENT,MTABE6
        CHARACTER*(8) ITABE6(NM6)
      ENDSEGMENT
 
*
      character * 8 toto
      INTEGER IDAN(4)
      NM5=0
*
*     Boucle sur les CHAMELEMs contenus dans la pile:
*
      DO 10 IEL=IDEB,IMAX1
*
         MCHELM  = ITLAC(IEL)
         IF (MCHELM.EQ.0) GO TO 10
*
            SEGACT,MCHELM
            N1      = ICHAML(/1)
            N3      = INFCHE(/2)
            LTITR   = TITCHE(/1)
            IDAN(1) = N1
            IDAN(2) = IFOCHE
            IDAN(3) = N3
            IDAN(4) = LTITR
*
            CALL ECDIFE(IOSAU,4,IDAN,IFORM)
            CALL ECDIFC(IOSAU,TITCHE,IFORM)
*
*         ECRITURE DU CONTENU DU SEGMENT MCHELM :
*
            N6 = N3 + 3
            NM1 = N1 * N6
            SEGINI,MTABE1
            IF(IONIVE.GE.4) THEN
               NM5 = N1 * 2
               SEGINI,MTABE5
            ENDIF
            nm6=N1
            segini mtabe6
            DO 21 ISOUEL=1,N1
               ISOU = N6 * (ISOUEL - 1)
               MCHAML = ICHAML(ISOUEL)
               SEGACT,MCHAML
*
               ITABE1(ISOU+1) = IMACHE(ISOUEL)
               ITABE1(ISOU+2) = ICHAML(ISOUEL)
               ITABE1(ISOU+3) = NOMCHE(/2)
               DO 12 IJ=1,N3
                  ITABE1(ISOU+3+IJ) = INFCHE(ISOUEL,IJ)
  12           CONTINUE
*
               IF(IONIVE.GE.4) THEN
                  ITABE5(2*ISOUEL-1) = CONCHE(ISOUEL)(1:8)
                  ITABE5(2*ISOUEL  ) = CONCHE(ISOUEL)(9:16)
               ENDIF
               toto = conche(isouel)(17:24)
               ITABE6(ISOUEL)=toto
 
*
  21        CONTINUE
            CALL ECDIFE(IOSAU,NM1,ITABE1,IFORM)
            SEGSUP MTABE1
            IF(IONIVE.GE.4) THEN
               CALL ECDIFN(IOSAU,NM5,MTABE5,IFORM)
               SEGSUP MTABE5
            ENDIF
               CALL ECDIFN(IOSAU,NM6,MTABE6,IFORM)
               segsup mtabe6
*
*       ... BOUCLES SUR LES ZONES ÉLÉMENTAIRES DU CHAMELEM :
*
            DO 22 ISOUEL=1,N1
               MCHAML = ICHAML(ISOUEL)
               N2  = NOMCHE(/2)
               NM2=N2
               NM4=N2*2
               SEGINI MTABE2,MTABE3,MTABE4
*
               DO 31 ICO=1,N2
                  ITABE2(ICO) = IELVAL(ICO)
                  ITABE3(ICO) = NOMCHE(ICO)
                 if (iform.ne.2) then
                  READ(TYPCHE(ICO),FMT='(2A8)') ITABE4(2*ICO-1),
     &                                          ITABE4(2*ICO  )
                 else
                  ITABE4(2*ICO-1)=TYPCHE(ICO)(1:8)
                  ITABE4(2*ICO  )=TYPCHE(ICO)(9:16)
                 endif
  31           CONTINUE
*
               CALL ECDIFE(IOSAU,NM2,ITABE2,IFORM)
               CALL ECDIFN(IOSAU,NM2,MTABE3,IFORM)
               CALL ECDIFN(IOSAU,NM4,MTABE4,IFORM)
               SEGSUP MTABE2,MTABE3,MTABE4
*
*          ... BOUCLE SUR LES COMPOSANTES :
*
               DO 32 ICO=1,N2
                  MELVAL = IELVAL(ICO)
*  si melval negatif c'est qu'il pointe sur un ielval et c'est donc ecrit dans wrielv
                  if (melval.gt.0) then
                  SEGACT,MELVAL
                  IDAN (1) = VELCHE(/1)
                  IDAN (2) = VELCHE(/2)
                  IDAN (3) = IELCHE(/1)
                  IDAN (4) = IELCHE(/2)
 
                  CALL ECDIFE(IOSAU,4,IDAN,IFORM)
*
*             ... ECRITURE DU CONTENU DU SEGMENT MELVAL :
*
                  L1 = IDAN(1) * IDAN(2)
                  L2 = IDAN(3) * IDAN(4)
                  CALL ECDIFR(IOSAU,L1,VELCHE,IFORM)
                  CALL ECDIFE(IOSAU,L2,IELCHE,IFORM)
                  SEGDES,MELVAL
                  endif
 32            CONTINUE
*
               SEGDES MCHAML
 22         CONTINUE
*
            SEGDES MCHELM
 
 10   CONTINUE
*
      RETURN
      END