1 : C WRCHPO SOURCE PV 12/12/17 21:15:23 7625 2 : SUBROUTINE WRCHPO (ISORTIE,ITLACC,IMAX1,IFORM,IDEB) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C======================================================================= 6 : C BUT : ECRITURE DES CHPOINT SUR LE FICHIER ISORTIE 7 : C APPELE PAR : WRPIL (SAUV ?) 8 : C APPELLE : ECDIFE ECDIFM ECDIFR 9 : C : ECDES ECDIFP JDANSI 10 : C ECRIT PAR FARVACQUE - REPRIS PAR LENA 11 : C======================================================================= 12 : C======================================================================= 13 : -INC CCOPTIO 14 : -INC SMCHPOI 15 : SEGMENT/ITLACC/(ITLAC(0)),ITLAC1.ITLACC,ITLAC2.ITLACC, 16 : 1 ITLAC3.ITLACC,ITLAC4.ITLACC,ITLAC5.ITLACC,ITLAC6.ITLACC 17 : C======================================================================= 18 : C======================================================================= 19 : SEGMENT/ITBBE1/( ITABE1(NN)) 20 : SEGMENT/ITBBE2/( ITABE2(NN)) 21 : SEGMENT/ITBBE3/( ITABE3(NN)) 22 : SEGMENT/ITBBM1/( ITABM1(NM)) 23 : SEGMENT ITBBC1 24 : character*4 itabc1(nm) 25 : ENDSEGMENT 26 : * SEGMENT ITBBC2 27 : * character*4 itabc2(nm2) 28 : * ENDSEGMENT 29 : 30 : SEGMENT/ITBBM2/( ITABM2(NM2)) 31 : SEGMENT/ITABR1/( TABR1(L)) 32 : C 33 : DIMENSION ILENA(10) 34 : character*80 itabc2 35 : C====================================================================== 36 : C 37 : C **************************CHPOINT********************************* 38 : 6002 CONTINUE 39 : NM2=20 40 : SEGINI ITBBM2 41 : C 42 : C ... BOUCLE SUR LES CHPO DE LA PILE 43 : DO 1101 IEL=IDEB,IMAX1 44 : C write(6,*) ' ' 45 : C write(6,*) ' ' 46 : MCHPOI=ITLAC(IEL) 47 : IF (MCHPOI.EQ.0) THEN 48 : C ... LE CHPO EST VIDE 49 : 11 ILENA(1)= 0 50 : ILENA(2)= 0 51 : ILENA(3)= 0 52 : ILENA(4)= 0 53 : ITOTO=3 54 : IF (IONIVE .GE. 6) ITOTO=4 54 : CALL ECDIFE(ISORTIE,ITOTO,ILENA,IFORM) 55 : ELSE 56 : 57 : SEGACT MCHPOI 58 : NSOUPO=IPCHP(/1) 59 : if (nsoupo.gt.1000.or.nsoupo.le.0) nsoupo = 0 60 : C WRITE(6,*) ' WRCHPO MCHPOI NSOUPO ',MCHPOI,NSOUPO 61 : NSOUP3=3*NSOUPO 62 : NN=NSOUP3 63 : SEGINI ITBBE1 64 : NM=0 65 : SEGINI ITBBM1,ITBBC1 66 : NN=0 67 : SEGINI ITBBE2 68 : NN=0 69 : SEGINI ITBBE3 70 : ICC=0 71 : 72 : IF (NSOUPO.EQ.0) GO TO 12 73 : C 74 : C ... BOUCLE SUR LES SOUS CHPO POUR REMPLIR DES TABLES DE DIMENSION 75 : DO 1103 ISOU=1,NSOUPO 76 : MSOUPO=IPCHP(ISOU) 77 : C WRITE(6,*)' LOOP ISOU MSOUPO ',ISOU,MSOUPO 78 : N=0 79 : NC=0 80 : IF (MSOUPO.EQ.0 ) GO TO 15 81 : SEGACT MSOUPO 82 : NC=NOCOMP(/2) 83 : C WRITE(6,*)' NC IPOVAL ',NC,IPOVAL 84 : MPOVAL=IPOVAL 85 : C write(6,*) ' mpoval ' , mpoval 86 : IF (MPOVAL.EQ.0) GO TO 16 87 : SEGACT MPOVAL 88 : N=VPOCHA(/1) 89 : C NC=VPOCHA(/2) 90 : 16 IVA=IGEOC 91 : ITABE1(3*ISOU -2)=IVA 92 : ITABE1(3*ISOU -1)=N 93 : ITABE1(3*ISOU )=NC 94 : NM=NM+NC 95 : NN=NM 96 : C write(6,*) ' nc n iva ' , nc , n , iva 97 : SEGADJ ITBBM1,itbbc1 98 : SEGADJ ITBBM1 99 : SEGADJ ITBBE2 100 : DO 1102 IC=1,NC 101 : ICC=ICC+1 102 : READ (NOCOMP(IC),FMT='(A4)') ITABM1(ICC) 103 : itabc1(icc)=nocomp(ic) 104 : ITABE2(ICC)=NOHARM(IC) 105 : 1102 CONTINUE 106 : 15 CONTINUE 107 : 1103 CONTINUE 108 : C ... FIN BOUCLE SUR SOUS CHPO 109 : C ... ON ECRIT LE CHAPEAU ET LES DIMENSIONS 110 : 12 CONTINUE 111 : ILENA(1)= NSOUPO 112 : ILENA(2)= NM 113 : ILENA(3)= IFOPOI 114 : C write(6,*)'wrch iel',iel,' nsoupo ', nsoupo, ' nm',nm,'ifo',ifopoi 115 : C ... SAUVE NOMBRE D'ATTRIBUT DANS ILENA 116 : NAT = JATTRI(/1) 117 : ILENA(4)= NAT 118 : ITOTO=3 119 : IF (IONIVE .GE. 6) ITOTO=4 120 : C write(6,*) ' premier appel ecdife itoto ', itoto 120 : CALL ECDIFE(ISORTIE,ITOTO,ILENA,IFORM) 121 : C write(6,*) ' deuxieme appel ecdife nsoup3 ', nsoup3 121 : CALL ECDIFE(ISORTIE,NSOUP3,ITABE1,IFORM) 122 : C write(6,*) ' troiseme appel ecdifm nm ' , nm 122 : if (iform.ne.2) CALL ECDIFM(ISORTIE,NM,ITABM1,IFORM) 122 : if (iform.eq.2) call ecdien(isortie,nm,itbbc1,iform) 123 : C write(6,*) ' quatrieme appel ecdife nn ', nn 123 : CALL ECDIFE(ISORTIE,NN,ITABE2,IFORM) 124 : READ (MTYPOI,FMT='(2A4)') ITABM2(1),ITABM2(2) 125 : itabc2(1:8)=mtypoi 126 : READ (MOCHDE,FMT='(18A4)') (ITABM2(I+2),I=1,18) 127 : itabc2(9:80)= mochde 128 : C write(6,*) ' cinquieme appel ecdifm nm2 ' , nm2 128 : if (iform.ne.2) CALL ECDIFM (ISORTIE,NM2,ITABM2,IFORM) 128 : if (iform.eq.2) call ecdifc(isortie,itabc2,iform) 129 : C ... VALEUR DES ATTRIBUTS 130 : IF (IONIVE .GE. 6) THEN 131 : NN = NAT 132 : SEGINI ITBBE3 133 : DO 1105 I=1 , NAT 134 : ITABE3(I) = JATTRI(I) 135 : 1105 CONTINUE 136 : C write(6,*) ' sixieme appel ecdife nat ', nat 136 : CALL ECDIFE(ISORTIE,NAT,ITABE3,IFORM) 137 : ENDIF 138 : C 139 : IF (NSOUPO.EQ.0) GO TO 14 140 : C ... BOUCLE SUR LES SOUS CHPO POUR ECRIRE LES VPOCHA 141 : DO 1104 ISOU=1,NSOUPO 142 : MSOUPO=IPCHP(ISOU) 143 : C write(6,*) ' isou msoupo', isou, msoupo 144 : IF (MSOUPO.EQ.0) GO TO 1104 145 : MPOVAL=IPOVAL 146 : IF (MPOVAL.EQ.0) GO TO 114 147 : L=ITABE1(3*ISOU-1)*ITABE1(3*ISOU) 148 : C write(6,*) 'ecriture enreg ' ,6+isou 148 : CALL ECDIFR(ISORTIE,L,VPOCHA,IFORM) 149 : IF (MPOVAL.NE.0) SEGDES MPOVAL 150 : 114 SEGDES MSOUPO 151 : 1104 CONTINUE 152 : C ... FIN BOUCLE SUR SOUS CHPO 153 : 14 CONTINUE 154 : SEGSUP ITBBE1,ITBBM1,ITBBE2,itbbc1 155 : * SEGSUP ITBBE1,ITBBM1,ITBBE2 156 : SEGDES MCHPOI 157 : ENDIF 158 : C ... FIN BOUCLE SUR CHPO 159 : 1101 CONTINUE 160 : SEGSUP ITBBM2 161 : GOTO 1098 162 : C ****************************************************************** 163 : 1098 CONTINUE 164 : C 165 : RETURN 166 : END 167 : 168 : 169 : 170 : 171 :
© Cast3M 2003 - All rights reserved.
Disclaimer