Sources Esope | Cast3M

wrchpo
C WRCHPO    SOURCE    CB215821  20/11/25    13:43:00     10792          
      SUBROUTINE WRCHPO (ISORTIE,ITLACC,IMAX1,IFORM,IDEB,LCOMWR)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C      BUT     : ECRITURE DES CHPOINT SUR LE FICHIER ISORTIE
C      APPELE PAR : WRPIL (SAUV ?)
C      APPELLE : ECDIFE ECDIFM ECDIFR
C              : ECDES  ECDIFP JDANSI
C      ECRIT PAR FARVACQUE   - REPRIS PAR LENA
C
C  (E) LCOMWR  : Longueur des Noms de composantes a ecrire (depuis NIVEAU 23)
C=======================================================================
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
      SEGMENT/ITLACC/(ITLAC(0)),ITLAC1.ITLACC,ITLAC2.ITLACC,
     1 ITLAC3.ITLACC,ITLAC4.ITLACC,ITLAC5.ITLACC,ITLAC6.ITLACC
C=======================================================================
C=======================================================================
      SEGMENT/ITBBE1/( ITABE1(NN))
      SEGMENT/ITBBE2/( ITABE2(NN))
      SEGMENT/ITBBE3/( ITABE3(NN))
      SEGMENT/ITBBM1/( ITABM1(NM))
      SEGMENT ITBBC1
        character*(LCOMWR) itabc1(nm)
      ENDSEGMENT
*      SEGMENT ITBBC2
*      character*4 itabc2(nm2)
*      ENDSEGMENT
 
      SEGMENT/ITBBM2/( ITABM2(NM2))
      SEGMENT/ITABR1/( TABR1(L))
C
      DIMENSION ILENA(10)
       character*80 itabc2
C======================================================================
C
C     **************************CHPOINT*********************************
 6002 CONTINUE
      NM2=20
      SEGINI ITBBM2
 
      IF(IONIVE .LT. 23)THEN
C       Les noms des composantes sont ecrits sur 4      caracteres
        LCOMWR=4
 
      ELSE
C       Les noms des composantes sont ecrits sur LOCOMP caracteres
        LCOMWR=LOCOMP
      ENDIF
C
C ... BOUCLE SUR LES CHPO DE LA PILE
      DO 1101 IEL=IDEB,IMAX1
C      write(6,*) ' '
C      write(6,*) ' '
         MCHPOI=ITLAC(IEL)
         IF (MCHPOI.EQ.0) THEN
C       ... LE CHPO EST VIDE
   11       ILENA(1)= 0
            ILENA(2)= 0
            ILENA(3)= 0
            ILENA(4)= 0
            ITOTO=3
            IF (IONIVE .GE. 6) ITOTO=4
            CALL ECDIFE(ISORTIE,ITOTO,ILENA,IFORM)
         ELSE
 
            SEGACT MCHPOI
            NSOUPO=IPCHP(/1)
            if (nsoupo.gt.1000.or.nsoupo.le.0) nsoupo = 0
C           WRITE(6,*) ' WRCHPO MCHPOI NSOUPO ',MCHPOI,NSOUPO
            NSOUP3=3*NSOUPO
            NN=NSOUP3
            SEGINI ITBBE1
            NM=0
            SEGINI ITBBM1,ITBBC1
            NN=0
            SEGINI ITBBE2
            NN=0
            SEGINI ITBBE3
            ICC=0
 
            IF (NSOUPO.EQ.0) GO TO 12
C
C       ... BOUCLE SUR  LES  SOUS CHPO POUR REMPLIR DES TABLES DE DIMENSION
            DO 1103 ISOU=1,NSOUPO
               MSOUPO=IPCHP(ISOU)
C              WRITE(6,*)' LOOP ISOU MSOUPO ',ISOU,MSOUPO
               N=0
               NC=0
               IF (MSOUPO.EQ.0 ) GO TO 15
               SEGACT MSOUPO
               NC=NOCOMP(/2)
C              WRITE(6,*)' NC IPOVAL ',NC,IPOVAL
               MPOVAL=IPOVAL
C               write(6,*) ' mpoval ' , mpoval
               IF (MPOVAL.EQ.0) GO TO 16
               SEGACT MPOVAL
               N=VPOCHA(/1)
C              NC=VPOCHA(/2)
   16          IVA=IGEOC
               ITABE1(3*ISOU -2)=IVA
               ITABE1(3*ISOU -1)=N
               ITABE1(3*ISOU   )=NC
               NM=NM+NC
               NN=NM
C               write(6,*) ' nc n iva ' , nc , n , iva
               SEGADJ ITBBM1,itbbc1,ITBBE2
               DO 1102 IC=1,NC
                  ICC=ICC+1
                  READ(NOCOMP(IC),FMT='(A4)') ITABM1(ICC)
                  itabc1(icc)=nocomp(ic)
                  ITABE2(ICC)=NOHARM(IC)
 1102          CONTINUE
   15          CONTINUE
 1103       CONTINUE
C       ... FIN BOUCLE SUR SOUS CHPO
C       ... ON ECRIT LE CHAPEAU ET LES DIMENSIONS
   12       CONTINUE
            ILENA(1)= NSOUPO
            ILENA(2)= NM
            ILENA(3)= IFOPOI
C      write(6,*)'wrch iel',iel,' nsoupo ', nsoupo, ' nm',nm,'ifo',ifopoi
C       ... SAUVE NOMBRE D'ATTRIBUT DANS ILENA
            NAT = JATTRI(/1)
            ILENA(4)= NAT
            ITOTO=3
            IF (IONIVE .GE. 6) ITOTO=4
C            write(6,*) ' premier appel ecdife itoto ', itoto
            CALL ECDIFE(ISORTIE,ITOTO,ILENA,IFORM)
C            write(6,*) ' deuxieme appel ecdife nsoup3 ', nsoup3
            CALL ECDIFE(ISORTIE,NSOUP3,ITABE1,IFORM)
C            write(6,*) ' troiseme appel ecdifm nm ' , nm
 
            IF(IONIVE .LE. 22)THEN
              if (iform.ne.2) CALL ECDIFM(ISORTIE,NM,ITABM1,IFORM)
              if (iform.eq.2) call ecdien(isortie,itbbc1,iform)
            ELSE
C             Depuis le niveau 23 on simplifie
              call ecdien(isortie,itbbc1,iform)
            ENDIF
 
C            write(6,*) ' quatrieme appel ecdife nn ', nn
            CALL ECDIFE(ISORTIE,NN,ITABE2,IFORM)
            itabc2(1:8)=mtypoi
            if (ichar(itabc2(1:1)).eq.0) itabc2(1:8)=' '
            READ (itabc2(1:8),FMT='(2A4)') ITABM2(1),ITABM2(2)
             itabc2(9:80)= mochde
            if (ichar(itabc2(9:9)).eq.0) itabc2(9:80)=' '
            READ (itabc2(9:80),FMT='(18A4)') (ITABM2(I+2),I=1,18)
C            write(6,*) ' cinquieme appel ecdifm nm2 ' , nm2
            if (iform.ne.2) CALL ECDIFM (ISORTIE,NM2,ITABM2,IFORM)
            if (iform.eq.2) call ecdifc(isortie,itabc2,iform)
C       ... VALEUR DES ATTRIBUTS
            IF (IONIVE .GE. 6) THEN
               NN = NAT
               SEGINI ITBBE3
               DO 1105 I=1 , NAT
                  ITABE3(I) = JATTRI(I)
 1105          CONTINUE
C            write(6,*) ' sixieme appel ecdife nat ', nat
               CALL ECDIFE(ISORTIE,NAT,ITABE3,IFORM)
            ENDIF
C
            IF (NSOUPO.EQ.0) GO TO 14
C       ... BOUCLE SUR LES SOUS CHPO POUR ECRIRE LES VPOCHA
            DO 1104 ISOU=1,NSOUPO
               MSOUPO=IPCHP(ISOU)
C               write(6,*) ' isou msoupo', isou, msoupo
               IF (MSOUPO.EQ.0) GO TO 1104
               MPOVAL=IPOVAL
               IF (MPOVAL.EQ.0) GO TO 114
               L=ITABE1(3*ISOU-1)*ITABE1(3*ISOU)
C             write(6,*) 'ecriture enreg  ' ,6+isou
               CALL ECDIFR(ISORTIE,L,VPOCHA,IFORM)
               IF (MPOVAL.NE.0) SEGDES MPOVAL
  114          SEGDES MSOUPO
 1104       CONTINUE
C       ... FIN BOUCLE SUR SOUS CHPO
   14       CONTINUE
            SEGSUP ITBBE1,ITBBM1,ITBBE2,itbbc1
*            SEGSUP ITBBE1,ITBBM1,ITBBE2
            SEGDES MCHPOI
         ENDIF
C ... FIN BOUCLE SUR CHPO
 1101 CONTINUE
      SEGSUP ITBBM2
      GOTO 1098
C     ******************************************************************
 1098 CONTINUE
 
      END