1 : C ACTICH SOURCE PV 09/03/12 21:15:07 6325 2 : SUBROUTINE ACTICH(FLOT,IPCH1,IPCH2,IPCH3,MACOMP,IPCH4) 3 : 4 : C-------------------------------------------------------------------- 5 : C ACCELERATION SUR UNE COMPOSANTE D'UN CHAMELEM 6 : C-------------------------------------------------------------------- 7 : IMPLICIT INTEGER(I-N) 8 : IMPLICIT REAL*8(A-H,O-Z) 9 : -INC SMCHAML 10 : -INC CCOPTIO 11 : * 12 : SEGMENT NOMID 13 : CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC) 14 : ENDSEGMENT 15 : * 16 : SEGMENT NOTYPE 17 : 18 : CHARACTER*16 TYPE(NBTYPE) 19 : ENDSEGMENT 20 : * 21 : SEGMENT MPTVAL 22 : INTEGER IPOS(NS) ,NSOF(NS) 23 : INTEGER IVAL(NCOSOU) 24 : CHARACTER*16 TYVAL(NCOSOU) 25 : ENDSEGMENT 26 : * 27 : PARAMETER ( NINF=3 ) 28 : INTEGER INFOS(NINF) 29 : CHARACTER*4 MACOMP 30 : CHARACTER*16 MOT1,MOT2,MOT3 31 : CHARACTER*(nconch) CONM 32 : * 33 : * 34 : * Verification du lieu support des MCHAMLs 35 : * 35 : CALL QUESUP (0,IPCH1,0,0,ISUP1,IRET1) 36 : IF(IERR.NE.0)RETURN 36 : CALL QUESUP (0,IPCH2,0,0,ISUP2,IRET2) 37 : IF(IERR.NE.0)RETURN 37 : CALL QUESUP (0,IPCH3,0,0,ISUP3,IRET3) 38 : IF(IERR.NE.0)RETURN 39 : IF((ISUP1.EQ.ISUP2.AND.ISUP1.EQ.ISUP3) 40 : 1 .OR. 41 : 1 ((ISUP1.EQ.0.AND.ISUP2.EQ.0).OR. 42 : 1 (ISUP2.EQ.0.AND.ISUP3.EQ.0).OR. 43 : 1 (ISUP3.EQ.0.AND.ISUP1.EQ.0)) 44 : 1 .OR. 45 : 1 ((ISUP1.EQ.0.AND.ISUP2.EQ.ISUP3).OR. 46 : 1 (ISUP2.EQ.0.AND.ISUP3.EQ.ISUP1).OR. 47 : 1 (ISUP3.EQ.0.AND.ISUP1.EQ.ISUP2)))THEN 48 : IOK=1 49 : ELSE 50 : IOK=0 51 : ENDIF 52 : IF(IOK.EQ.0)THEN 53 : MCHELM=IPCH1 54 : SEGACT MCHELM 55 : MOTERR(1:8)=TITCHE 55 : CALL ERREUR(124) 56 : SEGDES MCHELM 57 : RETURN 58 : ENDIF 59 : C 60 : C ON COPIE LE TROISIEME MCHAML 61 : C 62 : 62 : CALL COPIE8(IPCH3,IPCH4) 63 : MCHEL1=IPCH1 64 : MCHEL2=IPCH2 65 : MCHEL3=IPCH3 66 : SEGACT,MCHEL1,MCHEL2,MCHEL3 67 : MOT1=MCHEL1.TITCHE 68 : MOT2=MCHEL2.TITCHE 69 : MOT3=MCHEL3.TITCHE 70 : IF(MOT1.NE.MOT2.OR.MOT1.NE.MOT3)THEN 70 : CALL ERREUR(253) 70 : CALL DTCHAM(IPCH4) 71 : GOTO 666 72 : ENDIF 73 : MCHEL4=IPCH4 74 : SEGACT MCHEL4 75 : NSOU4=MCHEL4.IMACHE(/1) 76 : C 77 : C BOUCLE SUR LES ZONES 78 : C 79 : DO 500 ISOUS=1,NSOU4 80 : C 81 : IPMAIL=MCHEL4.IMACHE(ISOUS) 82 : CONM=MCHEL4.CONCHE(ISOUS) 83 : C 84 : C CREATION DU TABLEAU INFOS 85 : C 85 : CALL IDENT(IPMAIL,CONM,IPCH1,IPCH2,INFOS,IRTD) 86 : IF (IRTD.EQ.0) THEN 87 : SEGDES MCHEL4 87 : CALL DTCHAM(IPCH4) 88 : GOTO 666 89 : ENDIF 90 : C 91 : MCHAML=MCHEL4.ICHAML(ISOUS) 92 : SEGACT MCHAML 93 : NCOMP=IELVAL(/1) 94 : NBRFAC=0 95 : NBTYPE=NCOMP 96 : SEGINI NOTYPE 97 : MOTYPE=NOTYPE 98 : NBROBL=NCOMP 99 : SEGINI NOMID 100 : MONOM=NOMID 101 : DO 10 IC=1,NCOMP 102 : LESOBL(IC)=NOMCHE(IC) 103 : TYPE(IC)=TYPCHE(IC) 104 : 10 CONTINUE 105 : C 106 : NUMCO=0 107 : IF(NCOMP.EQ.1)NUMCO=1 108 : IF(NCOMP.NE.1)THEN 109 : DO 20 IC=1,NCOMP 110 : IF(MACOMP.NE.NOMCHE(IC))GOTO 20 111 : NUMCO=IC 112 : GO TO 30 113 : 20 CONTINUE 114 : 30 CONTINUE 115 : ENDIF 116 : IF(NUMCO.EQ.0)THEN 117 : MOTERR(1:4)=MACOMP 117 : CALL ERREUR(243) 118 : SEGDES MCHAML 119 : SEGDES MCHEL4 119 : CALL DTCHAM(IPCH4) 120 : GO TO 666 121 : ENDIF 122 : C 123 : C ON VERIFIE SI ON A LES MEMES COMPOSANTES SUR LES AUTRES 124 : C CHAMPS ET ON LES EXTRAIT 125 : C 125 : CALL KOMCHA(IPCH1,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH1) 126 : IF(IERR.NE.0)THEN 127 : SEGSUP NOMID,NOTYPE 127 : CALL DTMVAL(IVACH1,1) 128 : SEGDES MCHAML 129 : SEGDES MCHEL4 129 : CALL DTCHAM(IPCH4) 130 : GO TO 666 131 : ENDIF 131 : CALL KOMCHA(IPCH2,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH2) 132 : IF(IERR.NE.0)THEN 133 : SEGSUP NOMID,NOTYPE 133 : CALL DTMVAL(IVACH1,1) 133 : CALL DTMVAL(IVACH2,1) 134 : SEGDES MCHAML 135 : SEGDES MCHEL4 135 : CALL DTCHAM(IPCH4) 136 : GO TO 666 137 : ENDIF 137 : CALL KOMCHA(IPCH3,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH3) 138 : SEGSUP NOMID,NOTYPE 139 : C 140 : MELVAL=IELVAL(NUMCO) 141 : SEGACT,MELVAL 142 : NBPTE4=VELCHE(/1) 143 : NEL4 =VELCHE(/2) 144 : MPTVAL=IVACH1 145 : MELVAL=IVAL(NUMCO) 146 : NBPTE1=VELCHE(/1) 147 : NEL1 =VELCHE(/2) 148 : MPTVAL=IVACH2 149 : MELVAL=IVAL(NUMCO) 150 : NBPTE2=VELCHE(/1) 151 : NEL2 =VELCHE(/2) 152 : NBPTEL=MAX(MAX(NBPTE1,NBPTE2),NBPTE4) 153 : NBELEM=MAX(MAX(NEL1,NEL2),NEL4) 154 : N1PTEL=NBPTEL 155 : N1EL=NBELEM 156 : N2PTEL=0 157 : N2EL=0 158 : MELVAL=IELVAL(NUMCO) 159 : IF(N1PTEL.GT.NBPTE4.OR.N1EL.GT.NEL4)SEGADJ MELVAL 160 : C 161 : DO 100 IB=1,NBELEM 162 : DO 100 IGAU=1,NBPTEL 163 : C 164 : MPTVAL=IVACH1 165 : MELVAL=IVAL(NUMCO) 166 : IGMN=MIN(IGAU,VELCHE(/1)) 167 : IBMN=MIN(IB,VELCHE(/2)) 168 : V1=VELCHE(IGMN,IBMN) 169 : C 170 : MPTVAL=IVACH2 171 : MELVAL=IVAL(NUMCO) 172 : IGMN=MIN(IGAU,VELCHE(/1)) 173 : IBMN=MIN(IB,VELCHE(/2)) 174 : V2=VELCHE(IGMN,IBMN) 175 : C 176 : MPTVAL=IVACH3 177 : MELVAL=IVAL(NUMCO) 178 : IGMN=MIN(IGAU,VELCHE(/1)) 179 : IBMN=MIN(IB,VELCHE(/2)) 180 : V3=VELCHE(IGMN,IBMN) 181 : C 182 : RR=V3 183 : RD=V2-V1 184 : IF(RD.EQ.0.D0) GO TO 50 185 : RAI=(V3-V2)/RD 186 : IF(ABS(RAI).GT.FLOT) GO TO 50 187 : IF(RAI.EQ.1.D0) GO TO 50 188 : RR=V3+(V3-V2)*RAI/(1.D0-RAI) 189 : 50 CONTINUE 190 : MELVAL=IELVAL(NUMCO) 191 : VELCHE(IGAU,IB)=RR 192 : 100 CONTINUE 193 : C 194 : C DESACTIVATION DES SEGMENTS 195 : C 196 : C 196 : CALL DTMVAL(IVACH1,1) 197 : C 197 : CALL DTMVAL(IVACH2,1) 198 : C 198 : CALL DTMVAL(IVACH3,1) 199 : C 200 : MELVAL=IELVAL(NUMCO) 201 : SEGDES MELVAL 202 : SEGDES MCHAML 203 : C 204 : 500 CONTINUE 205 : SEGDES MCHEL4 206 : 666 CONTINUE 207 : SEGDES MCHEL1,MCHEL2,MCHEL3 208 : RETURN 209 : END 210 : 211 : 212 : 213 : 214 : 215 :
© Cast3M 2003 - All rights reserved.
Disclaimer