1 : C ADCHVE SOURCE CHAT 09/04/08 21:15:07 6355 2 : SUBROUTINE ADCHVE(IELVA1,IELVA2,XX,ICOD,IMELVA,IRET) 3 : * 4 : *_______________________________________________________________________ 5 : * 6 : * POUR VECTORISER L ADDITION DES CHAMELEMS 7 : * 8 : * ENTREE : 9 : * ________ 10 : * 11 : * IELVA1 POINTEUR SUR LE MELVAL DU 1IER CHAMELEM 12 : * IELVA2 POINTEUR SUR LE MELVA DU 2IEME CHAMELEM 13 : * XX COEFFICIENTS MULTIPLICATEUR 14 : * ICOD =1 --> MELVAL DE POINTEUR SUR MLREEL 15 : * =2 --> MELVAL DE POINTEUR SUR UN POINT 16 : * =3 --> MELVAL DE POINTEUR SUR UN EVOLUTIOn 17 : * =0 --> AUTRE CAS 18 : * 19 : * 20 : * SORTIES : 21 : * --------- 22 : * 23 : * IMELVA POINTEUR SUR LE MELVAL RESULTAT 24 : * IRET = 0 SI OK / =1 SINON 25 : * =104 POUR DECLENCHER LE MESSAGE D'ERREUR 104 26 : * =197 POUR DECLENCHER LE MESSAGE D'ERREUR 197 27 : * 28 : * EBERSOLT DECEMBRE 86 29 : * 30 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 29 10 90 31 : * +PP EXTENSION ADDITION P.PEGON 23/11/92 32 : * 33 : *______________________________________________________________________ 34 : * 35 : IMPLICIT INTEGER(I-N) 36 : IMPLICIT REAL*8(A-H,O-Z) 37 : * 38 : -INC CCOPTIO 39 : -INC SMCHAML 40 : -INC SMLREEL 41 : -INC SMCOORD 42 : -INC SMEVOLL 43 : * 44 : IRET=0 45 : MELVA1=IELVA1 46 : MELVA2=IELVA2 47 : SEGACT MELVA1 48 : SEGACT MELVA2 49 : * 50 : NBP1=MELVA1.VELCHE(/1) 51 : IF (NBP1.EQ.0) THEN 52 : NBP1=MELVA1.IELCHE(/1) 53 : NBP2=MELVA2.IELCHE(/1) 54 : NEL1=MELVA1.IELCHE(/2) 55 : NEL2=MELVA2.IELCHE(/2) 56 : N1PTEL=0 57 : N1EL =0 58 : N2PTEL=MAX(NBP1,NBP2) 59 : N2EL =MAX(NEL1,NEL2) 60 : SEGINI MELVAL 61 : IF (ICOD.EQ.1) THEN 62 : DO 1 IGAU=1,N2PTEL 63 : IGMN1=MIN(IGAU,MELVA1.IELCHE(/1)) 64 : IGMN2=MIN(IGAU,MELVA2.IELCHE(/1)) 65 : DO 1 IB=1,N2EL 66 : IBMN1=MIN(IB ,MELVA1.IELCHE(/2)) 67 : IBMN2=MIN(IB ,MELVA2.IELCHE(/2)) 68 : * 69 : MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) 70 : C PP SEGACT MLREE1 71 : MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) 72 : * 73 : IF(MLREE1.EQ.0)THEN 74 : MLREEL=MLREE2 75 : ELSEIF(MLREE2.EQ.0)THEN 76 : MLREEL=MLREE1 77 : ELSE 78 : SEGACT MLREE1 79 : * 80 : SEGACT MLREE2 81 : JG1=MLREE1.PROG(/1) 82 : JG2=MLREE2.PROG(/1) 83 : IJG=MIN(JG1,JG2) 84 : * 85 : JG=MAX(JG1,JG2) 86 : SEGINI MLREEL 87 : DO 2 IPROG=1,IJG 88 : PROG(IPROG)=MLREE1.PROG(IPROG)+XX*MLREE2.PROG(IPROG) 89 : 2 CONTINUE 90 : IF (JG.NE.IJG) THEN 91 : IF (IJG.EQ.JG1) THEN 92 : DO 10 IPROG=IJG+1,JG2 93 : PROG(IPROG)=XX*MLREE2.PROG(IPROG) 94 : 10 CONTINUE 95 : ELSE 96 : DO 20 IPROG=IJG+1,JG1 97 : PROG(IPROG)=MLREE1.PROG(IPROG) 98 : 20 CONTINUE 99 : ENDIF 100 : ENDIF 101 : SEGDES MLREE1,MLREE2,MLREEL 102 : ENDIF 103 : IELCHE(IGAU,IB)=MLREEL 104 : C PP SEGDES MLREE1,MLREE2,MLREEL 105 : 1 CONTINUE 106 : ELSE IF (ICOD.EQ.2) THEN 107 : DO 3 IGAU=1,N2PTEL 108 : IGMN1=MIN(IGAU,MELVA1.IELCHE(/1)) 109 : IGMN2=MIN(IGAU,MELVA2.IELCHE(/1)) 110 : DO 3 IB=1,N2EL 111 : * 112 : IBMN1=MIN(IB ,MELVA1.IELCHE(/2)) 113 : IBMN2=MIN(IB ,MELVA2.IELCHE(/2)) 114 : * 115 : C PP IP=MELVA1.IELCHE(IGMN1,IBMN1) 116 : C PP IREF1=(IP-1)*(IDIM+1) 117 : C PP IP=MELVA2.IELCHE(IGMN2,IBMN2) 118 : C PP IREF2=(IP-1)*(IDIM+1) 119 : * 120 : IP1=MELVA1.IELCHE(IGMN1,IBMN1) 121 : IP2=MELVA2.IELCHE(IGMN2,IBMN2) 122 : * 123 : IF(IP1.EQ.0)THEN 124 : NBPTS=IP2 125 : ELSEIF(IP2.EQ.0)THEN 126 : NBPTS=IP1 127 : ELSE 128 : IREF1=(IP1-1)*(IDIM+1) 129 : IREF2=(IP2-1)*(IDIM+1) 130 : * 131 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 132 : * 133 : SEGACT MCOORD 134 : NBNO=XCOOR(/1)/(IDIM+1) 135 : NBNOI=NBNO 136 : NBPTS=NBNO+1 137 : SEGADJ MCOORD 138 : * 139 : DO 4 IC=1,IDIM 140 : XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF1+IC)+ 141 : & XX*XCOOR(IREF2+IC) 142 : 4 CONTINUE 143 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF1+(IDIM+1)) 144 : ENDIF 145 : IELCHE(IGAU,IB)=NBPTS 146 : 3 CONTINUE 147 : ELSE IF (ICOD.EQ.3) THEN 148 : DO 6 IGAU=1,N2PTEL 149 : IGMN1=MIN(IGAU,MELVA1.IELCHE(/1)) 150 : IGMN2=MIN(IGAU,MELVA2.IELCHE(/1)) 151 : DO 6 IB=1,N2EL 152 : IBMN1=MIN(IB,MELVA1.IELCHE(/2)) 153 : IBMN2=MIN(IB,MELVA2.IELCHE(/2)) 154 : * 155 : MEVOL1=MELVA1.IELCHE(IGMN1,IBMN1) 156 : MEVOL2=MELVA2.IELCHE(IGMN2,IBMN2) 156 : CALL ADEVOL(MEVOL1,MEVOL2,IPEVAD,INT(XX)) 157 : IF (IPEVAD.EQ.0) IRET=1 158 : IELCHE(IGAU,IB)=IPEVAD 159 : 6 CONTINUE 160 : ELSE 161 : * 162 : * Y-A-T'IL UN DES DEUX POINTEURS NUL ? 163 : * 164 : DO IGAU=1,N2PTEL 165 : IGMN1=MIN(IGAU,MELVA1.IELCHE(/1)) 166 : IGMN2=MIN(IGAU,MELVA2.IELCHE(/1)) 167 : DO IB=1,N2EL 168 : IBMN1=MIN(IB ,MELVA1.IELCHE(/2)) 169 : IBMN2=MIN(IB ,MELVA2.IELCHE(/2)) 170 : IEL1=MELVA1.IELCHE(IGMN1,IBMN1) 171 : IEL2=MELVA2.IELCHE(IGMN2,IBMN2) 172 : IF (IEL1.EQ.0)THEN 173 : IELCHE(IGAU,IB)=IEL2 174 : ELSEIF(IEL2.EQ.0)THEN 175 : IELCHE(IGAU,IB)=IEL1 176 : ELSE 177 : * 178 : * NOM DE COMPOSANTE NON RECONNU 179 : * 180 : IRET=197 181 : SEGSUP MELVAL 182 : RETURN 183 : ENDIF 184 : ENDDO 185 : ENDDO 186 : ENDIF 187 : IMELVA=MELVAL 188 : ELSE 189 : NBP2=MELVA2.VELCHE(/1) 190 : NEL1=MELVA1.VELCHE(/2) 191 : NEL2=MELVA2.VELCHE(/2) 192 : N1PTEL=MAX(NBP1,NBP2) 193 : N1EL =MAX(NEL1,NEL2) 194 : N2PTEL=0 195 : N2EL =0 196 : SEGINI MELVAL 197 : DO 5 IGAU=1,N1PTEL 198 : IGMN1=MIN(IGAU,MELVA1.VELCHE(/1)) 199 : IGMN2=MIN(IGAU,MELVA2.VELCHE(/1)) 200 : DO 5 IB=1,N1EL 201 : * 202 : IBMN1=MIN(IB ,MELVA1.VELCHE(/2)) 203 : IBMN2=MIN(IB ,MELVA2.VELCHE(/2)) 204 : * 205 : VELCHE(IGAU,IB)=MELVA1.VELCHE(IGMN1,IBMN1)+ 206 : & XX*MELVA2.VELCHE(IGMN2,IBMN2) 207 : 5 CONTINUE 208 : IMELVA=MELVAL 209 : ENDIF 210 : SEGDES MELVAL 211 : SEGDES MELVA1 212 : SEGDES MELVA2 213 : * 214 : RETURN 215 : END 216 : 217 : 218 : 219 : 220 :
© Cast3M 2003 - All rights reserved.
Disclaimer