1 : C CHELCO SOURCE PV 09/03/12 21:17:01 6325 2 : SUBROUTINE CHELCO(IVAL,IPCHEL,IPCHE1,IPCHE2,IPCHE3) 3 : 4 : C======================================================================= 5 : C ENTREES 6 : C IVAL = 0 SI ON VEUT IDIM CHAMELEM CONTENANT CHACUN UNE COMPOSA 7 : C IVAL = 1 SI ON VEUT LA PREMIERE COMPOSANTE 8 : C IVAL = 2 SI ON VEUT LA DEUXIEME COMPOSANTE 9 : C IVAL = 3 SI ON VEUT LA TROISIEME COMPOSANTE 10 : C IPCHEL = POINTEUR SUR UN CHAMP PAR ELEMENT (TYPE MCHAML) 11 : 12 : C SORTIES 13 : C IPCHE1 =POINTEURS SUR LES CHAMP/ELEMENT CONTENANT LES COORDONNEES 14 : C IPCHE2 15 : C IPCHE3 16 : C 17 : C EBERSOLT OCT 85 18 : C NOUVEAUX CHAMELEMS P DOWLATYARI OCT 91 19 : C======================================================================= 20 : IMPLICIT INTEGER(I-N) 21 : IMPLICIT REAL*8(A-H,O-Z) 22 : -INC SMCHAML 23 : -INC SMELEME 24 : -INC SMINTE 25 : -INC SMCOORD 26 : -INC CCOPTIO 27 : -INC CCGEOME 28 : CHARACTER*4 NOMEL 29 : C 30 : SEGMENT MTRA 31 : REAL*8 XE(3,NBNN) 32 : ENDSEGMENT 33 : C 34 : DATA XZER/0.D0/ 35 : C 36 : C ON ACTIVE LE CHAMP/ELEMENT POUR EXTRAIRE LES INFOS NECESSAIRES 37 : C 38 : MCHEL1=IPCHEL 39 : SEGACT,MCHEL1 40 : N1=MCHEL1.INFCHE(/1) 41 : N3=MCHEL1.INFCHE(/2) 42 : L1=8 43 : NSOUS=N1 44 : C 45 : IF(IVAL.EQ.0)THEN 46 : IDEB=IDIM 47 : IFIN=1 48 : ELSE 49 : IDEB=IVAL 50 : IFIN=IVAL 51 : ENDIF 52 : C 53 : NCHE=0 54 : C 55 : C BOUCLE SUR LES COMPOSANTES 56 : C 57 : DO 1000 ICO=IDEB,IFIN,-1 58 : C 59 : C ON INITIALISE LE MCHAML CONTENANT LA COORDONNEE ICO 60 : C 61 : SEGINI,MCHELM 62 : NCHE=NCHE+1 63 : IF(NCHE.EQ.1)IPCHE1=MCHELM 64 : IF(NCHE.EQ.2)IPCHE2=MCHELM 65 : IF(NCHE.EQ.3)IPCHE3=MCHELM 66 : IFOCHE=MCHEL1.IFOCHE 67 : TITCHE='SCALAIRE' 68 : C 69 : C BOUCLE SUR LES SOUS-ZONES 70 : C 71 : DO 100 ISOUS=1,NSOUS 72 : C 73 : CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) 74 : IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) 75 : C 76 : DO 10 IO=1,N3 77 : INFCHE(ISOUS,IO)=MCHEL1.INFCHE(ISOUS,IO) 78 : 10 CONTINUE 79 : N2=1 80 : SEGINI MCHAML 81 : ICHAML(ISOUS)=MCHAML 82 : NOMCHE(1)='SCAL' 83 : TYPCHE(1)='REAL*8' 84 : C 85 : MELEME=IMACHE(ISOUS) 86 : SEGACT,MELEME 87 : NBELEM=NUM(/2) 88 : NBNN=NUM(/1) 89 : C 90 : ISUP=INFCHE(ISOUS,6) 91 : IF(ISUP.NE.1)THEN 92 : MINTE=INFCHE(ISOUS,4) 93 : SEGACT,MINTE 94 : NBPGAU=SHPTOT(/3) 95 : ELSE 96 : NBPGAU=NBNN 97 : ENDIF 98 : C 99 : N1EL=NBELEM 100 : N1PTEL=NBPGAU 101 : N2EL=0 102 : N2PTEL=0 103 : SEGINI MELVAL 104 : IELVAL(1)=MELVAL 105 : SEGINI MTRA 106 : C 107 : DO 200 IB=1,NBELEM 108 : C 108 : CALL ZERO(XE,3,NBNN) 108 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 109 : C 110 : DO 200 IGAU=1,NBPGAU 111 : C 112 : IF(ISUP.NE.1)THEN 113 : XX=XZER 114 : DO 220 ID=1,NBNN 115 : XX=XX+SHPTOT(1,ID,IGAU)*XE(ICO,ID) 116 : 220 CONTINUE 117 : ELSE 118 : XX=XE(ICO,IGAU) 119 : ENDIF 120 : C+PPj 121 : C ON DIVISE PAR 2 LE RESULTAT POUR LES ELEMENTS DE JOINTS 122 : NOMEL=NOMS(ITYPEL) 123 : IF((NOMEL.EQ.'RAC2').OR.(NOMEL.EQ.'RAC3').OR.(NOMEL.EQ.'LIA3') 124 : . .OR.(NOMEL.EQ.'LIA4').OR.(NOMEL.EQ.'LIA6').OR.(NOMEL.EQ.'LIA8')) 125 : . XX=XX/2 126 : C+PPj 127 : C 128 : VELCHE(IGAU,IB)=XX 129 : C 130 : 200 CONTINUE 131 : SEGDES,MELVAL,MCHAML,MELEME 132 : IF(ISUP.NE.1)SEGDES,MINTE 133 : SEGSUP MTRA 134 : C 135 : 100 CONTINUE 136 : C 137 : SEGDES MCHELM 138 : C 139 : 1000 CONTINUE 140 : C 141 : SEGDES MCHEL1 142 : RETURN 143 : END 144 : 145 : 146 : 147 : 148 : 149 : 150 : 151 : 152 : 153 :
© Cast3M 2003 - All rights reserved.
Disclaimer