1 : C PROJTA SOURCE BP208322 13/12/02 21:15:01 7870 2 : SUBROUTINE PROJTA(IP1,IP2,IRET) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : ************************************************************************ 6 : * * 7 : * PROJECTION DU CHAMP IP1 SUR LES ELEMENTS DE LA BASE MODALE IP2 * 8 : * * 9 : * PARAMETRES: * 10 : * * 11 : * E ip1 chpoint * 12 : * E it2 table des modes de sous-type base_de_modes * 13 : * S iret chpoint resultat * 14 : * * 15 : * REMARQUES: * 16 : * * 17 : * ce sous-programme est une copie de projba * 18 : * ce sous-programme est appele par pjba, psmo, copba4 * 19 : * * 20 : * AUTEUR, DATE DE CREATION: * 21 : * * 22 : * lionel vivan aout 1990 * 23 : * * 24 : ************************************************************************ 25 : * 26 : -INC CCOPTIO 27 : -INC CCGEOME 28 : -INC CCREEL 29 : -INC SMCHPOI 30 : -INC SMELEME 31 : -INC CCHAMP 32 : * 33 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 34 : SEGMENT IINC 35 : CHARACTER*4 CIINC(0) 36 : ENDSEGMENT 37 : SEGMENT IIDU 38 : CHARACTER*4 CIIDU(NNI1) 39 : ENDSEGMENT 40 : SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA 41 : SEGMENT IPB(IPR1) 42 : SEGMENT MCONTR(NNI1,IPR1) 43 : LOGICAL L0,L1 44 : CHARACTER*4 IDDL 45 : CHARACTER*8 TYPRET,CHARRE 46 : DATA KZERO/0/ 47 : c 48 : IRET = 0 49 : c 50 : c deplacement impose => idepi=1 51 : c force imposee => idepi=0 52 : c 53 : IDEPI = 0 54 : c idepi = -1 55 : KDEPI = 0 56 : MCHPOI = IP1 57 : SEGACT MCHPOI 58 : IF (MTYPOI.EQ.'FLX ') IDEPI = 1 59 : c if(mtypoi(1).eq.moforc(1).and.mtypoi(2).eq.moforc(2)) idepi=0 60 : SEGDES MCHPOI 61 : c if (idepi.lt.0) then 62 : c moterr(1:8) = 'chpoint' 62 : c call erreur(302) 63 : c return 64 : c endif 65 : c 66 : NBNN = 1 67 : NBREF = 0 68 : NBSOUS = 0 69 : * 70 : LDEPL = 0 71 : 10 CONTINUE 72 : LDEPL = LDEPL + 1 73 : TYPRET = ' ' 73 : CALL ACCTAB(IP2,'ENTIER',LDEPL,X0,' ',L0,IP0, 74 : & TYPRET,I1,X1,CHARRE,L1,ITMOD) 75 : IF (TYPRET.EQ.'TABLE ' .AND. ITMOD.NE.0) GOTO 10 76 : LDEPL = LDEPL - 1 77 : c 78 : c **** etalpr du chpoint de la solution 79 : c 80 : IND = 1 80 : CALL ACCTAB(IP2,'ENTIER',IND,X0,' ',L0,IP0, 81 : & 'TABLE',I1,X1,' ',L1,ITMOD) 81 : CALL ACCTAB(ITMOD,'MOT',I0,X0,'DEFORMEE_MODALE',L0,IP0, 82 : & 'CHPOINT',I1,X1,' ',L1,IPM) 82 : CALL ETALPR(IPM,KIINC,KICPR,KCONTR) 83 : IF (IERR.NE.0) RETURN 84 : MCONTR = KCONTR 85 : SEGACT MCONTR 86 : NNI1 = MCONTR(/1) 87 : IPR1 = MCONTR(/2) 88 : SEGDES MCONTR 89 : SEGINI MVA 90 : KMVA = MVA 91 : SEGDES MVA 92 : SEGINI MVA 93 : KMVB = MVA 94 : SEGDES MVA 95 : SEGINI IPB 96 : KIPB = IPB 97 : SEGDES IPB 98 : * fabrication de la liste des inconnues duales correspondant aux primales 99 : IINC = KIINC 100 : SEGACT IINC 101 : SEGINI IIDU 102 : DO 6 I = 1,NNI1 103 : IDDL = CIINC(I) 104 : DO 7 J = 1,LNOMDD 105 : IF(IDDL.NE.NOMDD(J)) GOTO 7 106 : CIIDU(I) = NOMDU(J) 107 : GOTO 6 108 : 7 CONTINUE 109 : MOTERR(1:4) = IDDL 109 : CALL ERREUR(108) 110 : c on ne trouve pas iddl dans CCHAMP 111 : RETURN 112 : 6 CONTINUE 113 : SEGDES IINC,IIDU 114 : KINCDU = IIDU 115 : c 116 : c **** on regarde si les points de f correspondent 117 : c **** on met f dans kmvb 118 : c 118 : CALL ETALCH(IP1,KINCDU,KICPR,KCONTR,KMVB,KIPB,NPR2) 119 : IF (IERR.NE.0) RETURN 120 : c 121 : c **** on initialise le chpoint 122 : c 123 : NSOUPO = 1 124 : NAT=1 125 : SEGINI,MCHPOI 126 : IRET = MCHPOI 127 : MTYPOI = ' ' 128 : MOCHDE=' J''AI ETE FABRIQUE PAR L''OPERATEUR PROJTA' 129 : IFOPOI = IFOUR 130 : * champ de force nodal: nature discrete 131 : JATTRI(1)=2 132 : NC = 1 133 : SEGINI,MSOUPO 134 : IPCHP(1) = MSOUPO 135 : NOCOMP(1) = 'FALF' 136 : NOHARM(1) = NIFOUR 137 : N = LDEPL 138 : SEGINI MPOVAL 139 : IPOVAL = MPOVAL 140 : * 141 : NBNN = 1 142 : NBELEM = LDEPL 143 : NBSOUS = 0 144 : NBREF = 0 145 : SEGINI MELEME 146 : IGEOC = MELEME 147 : ITYPEL = 1 148 : c 149 : c ****boucle sur les chpoints de depl 150 : c 151 : DO 11 IM = 1,LDEPL 151 : CALL ACCTAB(IP2,'ENTIER',IM,X0,' ',L0,IP0, 152 : & 'TABLE',I1,X1,' ',L1,ITMOD) 152 : CALL ACCTAB(ITMOD,'MOT',I0,X0,'POINT_REPERE',L0,IP0, 153 : & 'POINT',I1,X1,' ',L1,IPTR) 154 : NUM(1,IM) = IPTR 155 : ICOLOR(IM) = IDCOUL 155 : CALL ACCTAB(ITMOD,'MOT',I0,X0,'DEFORMEE_MODALE',L0,IP0, 156 : & 'CHPOINT',I1,X1,' ',L1,IPP1) 157 : XRET = 0.D0 158 : IF (IDEPI.NE.1) THEN 158 : CALL ETALCH(IPP1,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID) 159 : IF (IERR.NE.0) RETURN 160 : * 161 : MVA = KMVA 162 : IPB = KIPB 163 : MVA1 = KMVB 164 : SEGACT MVA,MVA1,IPB 165 : DO 80 J1 = 1,NPR2 166 : JJ1 = IPB(J1) 167 : DO 80 I1 = 1,NNI1 168 : XRET = XRET + VA(I1,JJ1) * MVA1.VA(I1,JJ1) 169 : 80 CONTINUE 170 : SEGDES MVA,MVA1,IPB 171 : ELSE 171 : CALL ACCTAB(ITMOD,'MOT',I0,X0,'FREQUENCE',L0,IP0, 172 : & 'FLOTTANT',I1,X1,' ',L1,IP1) 173 : OM = X1 174 : OM = 2.D0 * XPI * OM 175 : OM = OM * OM 176 : XRET = -XRET / OM 177 : cbp XRET vaut toujours 0 !?!?! 178 : ENDIF 179 : cbp IF (IFOUR .EQ. 1) THEN 180 : cbp IF (NIFOUR .NE. 0) THEN 181 : cbp XRET = XRET*XPI 182 : cbp ELSE 183 : cbp XRET = XRET*2.D0*XPI 184 : cbp ENDIF 185 : cbp ENDIF 186 : * if (ifour .eq. 0) xret = xret*2.d0*xpi 187 : VPOCHA(IM,1) = XRET 188 : 189 : 11 CONTINUE 190 : * 191 : SEGSUP MVA,MVA1,IPB 192 : ICPR = KICPR 193 : SEGSUP ICPR,IINC,IIDU 194 : * 195 : SEGDES MPOVAL,MELEME 196 : SEGDES MSOUPO 197 : SEGDES MCHPOI 198 : IF (IDEPI.NE.KDEPI) THEN 199 : *** la base ne contient pas la solution statique necessaire au 200 : *** calcul de la reponse au deplacement impose 200 : CALL ERREUR(303) 200 : CALL ECRCHA('GEOM') 200 : CALL DTCHPO(MCHPOI) 201 : IRET = 0 202 : ENDIF 203 : * 204 : END 205 : 206 : 207 : 208 : 209 : 210 : 211 : 212 : 213 : 214 : 215 : 216 : 217 : 218 :
© Cast3M 2003 - All rights reserved.
Disclaimer