1 : C WRCHAM SOURCE PV 09/03/12 21:37:06 6325 2 : SUBROUTINE WRCHAM(IOSAU,ITLACC,IMAX1,IFORM,IONIVE,IDEB) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : *--------------------------------------------------------------------* 6 : * * 7 : * Ecriture d'un nouveau CHAMELEM sur le fichier IOSAU. * 8 : * * 9 : * Paramètres: * 10 : * * 11 : * IOSAU Numéro du fichier de sortie * 12 : * ITLACC Pile contenant les nouveaux CHAMELEMs * 13 : * IMAX1 Nombre de CHAMELEMs dans la pile * 14 : * IFORM Si sauvegarde en format ou non * 15 : * * 16 : * Appelé par: WRPIL * 17 : * * 18 : * Auteur, date de création: * 19 : * * 20 : * Denis ROBERT-MOUGIN, le 29 juin 1989. * 21 : * ANNEE DU BICENTENAIRE DE LA REVOLUTION FRANCAISE * 22 : * * 23 : *--------------------------------------------------------------------* 24 : -INC SMCHAML 25 : -INC CCFXDR 26 : * 27 : SEGMENT,ITLACC 28 : INTEGER ITLAC(0) 29 : ENDSEGMENT 30 : SEGMENT,MTABE1 31 : INTEGER ITABE1(NM1) 32 : ENDSEGMENT 33 : SEGMENT,MTABE2 34 : INTEGER ITABE2(NM2) 35 : ENDSEGMENT 36 : SEGMENT,MTABE3 37 : CHARACTER*(8) ITABE3(NM2) 38 : ENDSEGMENT 39 : SEGMENT,MTABE4 40 : CHARACTER*(8) ITABE4(NM4) 41 : ENDSEGMENT 42 : SEGMENT,MTABE5 43 : CHARACTER*(8) ITABE5(NM5) 44 : ENDSEGMENT 45 : SEGMENT,MTABE6 46 : CHARACTER*(8) ITABE6(NM6) 47 : ENDSEGMENT 48 : 49 : * 50 : character * 8 toto 51 : INTEGER IDAN(4) 52 : NM5=0 53 : * 54 : * Boucle sur les CHAMELEMs contenus dans la pile: 55 : * 56 : DO 10 IEL=IDEB,IMAX1 57 : * 58 : MCHELM = ITLAC(IEL) 59 : IF (MCHELM.EQ.0) GO TO 10 60 : * 61 : SEGACT,MCHELM 62 : N1 = ICHAML(/1) 63 : N3 = INFCHE(/2) 64 : LTITR = TITCHE(/1) 65 : IDAN(1) = N1 66 : IDAN(2) = IFOCHE 67 : IDAN(3) = N3 68 : IDAN(4) = LTITR 69 : * 69 : CALL ECDIFE(IOSAU,4,IDAN,IFORM) 69 : CALL ECDIFC(IOSAU,TITCHE,IFORM) 70 : * 71 : * ECRITURE DU CONTENU DU SEGMENT MCHELM : 72 : * 73 : N6 = N3 + 3 74 : NM1 = N1 * N6 75 : SEGINI,MTABE1 76 : IF(IONIVE.GE.4) THEN 77 : NM5 = N1 * 2 78 : SEGINI,MTABE5 79 : ENDIF 80 : nm6=N1 81 : segini mtabe6 82 : DO 21 ISOUEL=1,N1 83 : ISOU = N6 * (ISOUEL - 1) 84 : MCHAML = ICHAML(ISOUEL) 85 : SEGACT,MCHAML 86 : * 87 : ITABE1(ISOU+1) = IMACHE(ISOUEL) 88 : ITABE1(ISOU+2) = ICHAML(ISOUEL) 89 : ITABE1(ISOU+3) = NOMCHE(/2) 90 : DO 12 IJ=1,N3 91 : ITABE1(ISOU+3+IJ) = INFCHE(ISOUEL,IJ) 92 : 12 CONTINUE 93 : * 94 : IF(IONIVE.GE.4) THEN 95 : ITABE5(2*ISOUEL-1) = CONCHE(ISOUEL)(1:8) 96 : ITABE5(2*ISOUEL ) = CONCHE(ISOUEL)(9:16) 97 : ENDIF 98 : toto = conche(isouel)(17:24) 99 : ITABE6(ISOUEL)=toto 100 : 101 : * 102 : 21 CONTINUE 102 : CALL ECDIFE(IOSAU,NM1,ITABE1,IFORM) 103 : SEGSUP MTABE1 104 : IF(IONIVE.GE.4) THEN 104 : CALL ECDIFN(IOSAU,NM5,MTABE5,IFORM) 105 : SEGSUP MTABE5 106 : ENDIF 106 : CALL ECDIFN(IOSAU,NM6,MTABE6,IFORM) 107 : segsup mtabe6 108 : * 109 : * ... BOUCLES SUR LES ZONES ÉLÉMENTAIRES DU CHAMELEM : 110 : * 111 : DO 22 ISOUEL=1,N1 112 : MCHAML = ICHAML(ISOUEL) 113 : N2 = NOMCHE(/2) 114 : NM2=N2 115 : NM4=N2*2 116 : SEGINI MTABE2,MTABE3,MTABE4 117 : * 118 : DO 31 ICO=1,N2 119 : ITABE2(ICO) = IELVAL(ICO) 120 : ITABE3(ICO) = NOMCHE(ICO) 121 : if (iform.ne.2) then 122 : READ(TYPCHE(ICO),FMT='(2A8)') ITABE4(2*ICO-1), 123 : & ITABE4(2*ICO ) 124 : else 125 : ITABE4(2*ICO-1)=TYPCHE(ICO)(1:8) 126 : ITABE4(2*ICO )=TYPCHE(ICO)(9:16) 127 : endif 128 : 31 CONTINUE 129 : * 129 : CALL ECDIFE(IOSAU,NM2,ITABE2,IFORM) 129 : CALL ECDIFN(IOSAU,NM2,MTABE3,IFORM) 129 : CALL ECDIFN(IOSAU,NM4,MTABE4,IFORM) 130 : SEGSUP MTABE2,MTABE3,MTABE4 131 : * 132 : * ... BOUCLE SUR LES COMPOSANTES : 133 : * 134 : DO 32 ICO=1,N2 135 : MELVAL = IELVAL(ICO) 136 : SEGACT,MELVAL 137 : IDAN (1) = VELCHE(/1) 138 : IDAN (2) = VELCHE(/2) 139 : IDAN (3) = IELCHE(/1) 140 : IDAN (4) = IELCHE(/2) 140 : CALL ECDIFE(IOSAU,4,IDAN,IFORM) 141 : * 142 : * ... ECRITURE DU CONTENU DU SEGMENT MELVAL : 143 : * 144 : L1 = IDAN(1) * IDAN(2) 145 : L2 = IDAN(3) * IDAN(4) 145 : CALL ECDIFR(IOSAU,L1,VELCHE,IFORM) 145 : CALL ECDIFE(IOSAU,L2,IELCHE,IFORM) 146 : SEGDES,MELVAL 147 : 32 CONTINUE 148 : * 149 : SEGDES MCHAML 150 : 22 CONTINUE 151 : * 152 : SEGDES MCHELM 153 : 154 : 10 CONTINUE 155 : * 156 : RETURN 157 : END 158 : 159 : 160 : 161 : 162 : 163 : 164 :
© Cast3M 2003 - All rights reserved.
Disclaimer