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