1 : C FSCOQ4 SOURCE FANDEUR 12/07/18 21:15:38 7434 2 : 3 : SUBROUTINE FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR) 4 : *____________________________________________________________________ 5 : * 6 : * CALCULE LES FORCES SURFACIQUES SUR LES COQUES COQ4 3D 7 : * 8 : * ENTREES : 9 : * --------- 10 : * 11 : * IPT TABLEAU DE POINTEURS SUR MPTVAL CONTENANT LES FORCES 12 : * APPLIQUEES 13 : * IPMAIL OBJET GEOMETRIQUE 14 : * IPTINT POINTEUR SUR UN MINTE CONTENANT LES POINTS D INTEGRATION 15 : * IPVECT POINTEUR SUR LE VECTEUR REPRESENTANT LA FORCE 16 : * V VECTEUR REPRESENTANT LA FORCE 17 : * IVAFOR POINTEUR SUR UN MPTVAL ET DES MELVALS DEVANT CONTENIR 18 : * LES FORCES NODALES RESULTANTES 19 : * 20 : * G. M. GIANNUZZI SETT 86 21 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12 09 90 22 : * 23 : *____________________________________________________________________ 24 : * 25 : IMPLICIT INTEGER(I-N) 26 : IMPLICIT REAL*8(A-H,O-Z) 27 : * 28 : -INC CCOPTIO 29 : * 30 : -INC SMCHAML 31 : -INC SMELEME 32 : -INC SMINTE 33 : -INC SMCOORD 34 : * 35 : SEGMENT MPTVAL 36 : INTEGER IPOS(NS) ,NSOF(NS) 37 : INTEGER IVAL(NCOSOU) 38 : CHARACTER*16 TYVAL(NCOSOU) 39 : ENDSEGMENT 40 : * 41 : DIMENSION IPT(*), V(*) 42 : 43 : DIMENSION XE(3,4),XEL(3,4),BPSS(3,3),SHP(6,4),FTLOC(24),FTGLO(24) 44 : 45 : MELVA1 = IPT(1) 46 : MELVA2 = IPT(2) 47 : MELVA3 = IPT(3) 48 : IF (IPVECT.EQ.0) THEN 49 : IF (MELVA1.NE.0) THEN 50 : SEGACT,MELVA1 51 : IGM1 = MELVA1.VELCHE(/1) 52 : IBM1 = MELVA1.VELCHE(/2) 53 : ENDIF 54 : IF (MELVA2.NE.0) THEN 55 : SEGACT,MELVA2 56 : IGM2 = MELVA2.VELCHE(/1) 57 : IBM2 = MELVA2.VELCHE(/2) 58 : ENDIF 59 : IF (MELVA3.NE.0) THEN 60 : SEGACT,MELVA3 61 : IGM3 = MELVA3.VELCHE(/1) 62 : IBM3 = MELVA3.VELCHE(/2) 63 : ENDIF 64 : F1 = 0.D0 65 : F2 = 0.D0 66 : F3 = 0.D0 67 : ELSE 68 : F1 = V(1) 69 : F2 = V(2) 70 : F3 = V(3) 71 : ENDIF 72 : * 73 : MINTE=IPTINT 74 : C* SEGACT,MINTE <- ACTIF EN E/S (NON MODIFIE) 75 : NBPGAU=POIGAU(/1) 76 : NBGM1 =NBPGAU-1 77 : * 78 : MELEME=IPMAIL 79 : C* SEGACT,MELEME <- ACTIF EN E/S (NON MODIFIE) 80 : NBPTEL = NUM(/1) 81 : NBELEM = NUM(/2) 82 : * 83 : * BOUCLE SUR LES ELEMENTS 84 : * 85 : DO 1000 IB=1,NBELEM 86 : * 86 : CALL DOXE(XCOOR,IDIM,NBPTEL,NUM,IB,XE) 87 : * 88 : * MATRICE DE PASSAGE ET COORDONNEES LOCALES 89 : * 89 : CALL CQ4LOC(XE,XEL,BPSS,IERR,0) 90 : * 91 : * MISE A 0 DU VECTEUR FORCE 92 : * 93 : DO I = 1, 24 94 : FTLOC(I)=0.D0 95 : ENDDO 96 : * 97 : * INTEGRATION NUMERIQUE : IGAU NUMERO DU POINT DE GAUSS 98 : * IA NUMERO D UN NOEUD 99 : * 100 : IF (IPVECT.EQ.0) THEN 101 : IF (MELVA1.NE.0) IBMN1 = MIN(IB,IBM1) 102 : IF (MELVA2.NE.0) IBMN2 = MIN(IB,IBM2) 103 : IF (MELVA3.NE.0) IBMN3 = MIN(IB,IBM3) 104 : ENDIF 105 : 106 : DO 200 IGAU=1,NBGM1 107 : * 108 : IF (IPVECT.EQ.0) THEN 109 : IF (MELVA1.NE.0) THEN 110 : IGMN = MIN(IGAU,IGM1) 111 : F1 = MELVA1.VELCHE(IGMN,IBMN1) 112 : ENDIF 113 : IF (MELVA2.NE.0) THEN 114 : IGMN = MIN(IGAU,IGM2) 115 : F2 = MELVA2.VELCHE(IGMN,IBMN2) 116 : ENDIF 117 : IF (MELVA3.NE.0) THEN 118 : IGMN = MIN(IGAU,IGM3) 119 : F3 = MELVA3.VELCHE(IGMN,IBMN3) 120 : ENDIF 121 : ENDIF 122 : * 123 : * chgt de repere des forces appliquees 124 : * 125 : F1L = BPSS(1,1)*F1 + BPSS(1,2)*F2 + BPSS(1,3)*F3 126 : F2L = BPSS(2,1)*F1 + BPSS(2,2)*F2 + BPSS(2,3)*F3 127 : F3L = BPSS(3,1)*F1 + BPSS(3,2)*F2 + BPSS(3,3)*F3 128 : * 129 : DO 210 NP = 1, NBPTEL 130 : SHP(1,NP) = SHPTOT(1,NP,IGAU) 131 : SHP(2,NP) = SHPTOT(2,NP,IGAU) 132 : SHP(3,NP) = SHPTOT(3,NP,IGAU) 133 : 210 CONTINUE 133 : CALL JACOBI(XEL,SHP,2,NBPTEL,DJAC) 134 : DJAC = DJAC*POIGAU(IGAU) 135 : * 136 : DJAC1 = DJAC*F1L 137 : DJAC2 = DJAC*F2L 138 : DJAC3 = DJAC*F3L 139 : * 140 : DO 250 NP = 1, NBPTEL 141 : IC1=(NP-1)*6+1 142 : IC2=IC1 + 1 143 : IC3=IC2 + 1 144 : FTLOC(IC1)=FTLOC(IC1)+SHP(1,NP)*DJAC1 145 : FTLOC(IC2)=FTLOC(IC2)+SHP(1,NP)*DJAC2 146 : FTLOC(IC3)=FTLOC(IC3)+SHP(1,NP)*DJAC3 147 : 250 CONTINUE 148 : 200 CONTINUE 149 : * 150 : * CHANGEMENT DE REPERE 151 : * 151 : CALL TRPOSE(BPSS) 151 : CALL MATVEC(FTLOC,FTGLO,BPSS,8) 152 : * 153 : MPTVAL=IVAFOR 154 : IE=0 155 : DO 560 IC=1,4 156 : DO 560 ID=1,6 157 : IE=IE+1 158 : MELVAL=IVAL(ID) 159 : VELCHE(IC,IB)=FTGLO(IE) 160 : 560 CONTINUE 161 : 162 : 1000 CONTINUE 163 : 164 : IF (IPVECT.EQ.0) THEN 165 : IF (MELVA1.NE.0) SEGDES,MELVA1 166 : IF (MELVA2.NE.0) SEGDES,MELVA2 167 : IF (MELVA3.NE.0) SEGDES,MELVA3 168 : ENDIF 169 : C* SEGDES,MINTE 170 : C* SEGDES,MELEME 171 : 172 : RETURN 173 : END 174 : 175 :
© Cast3M 2003 - All rights reserved.
Disclaimer