1 : C SEISME SOURCE CHAT 05/01/13 03:13:26 5004 2 : SUBROUTINE SEISME 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C************************************************************** 6 : C SOUS PROGRAMME ASSOCIE A L OPERATEUR SEISME 7 : C 8 : C 26/06/86 AUTEUR D. BROCHARD (VIBR) TEL 6994 9 : C 10 : C 11 : C CREATION D UN OBJET CHARGEMENT A PARTIR D UN OBJET 12 : C EVOLUTION, D UN OBJET BASE MODALE,D UN OBJET FLOTTANT, 13 : C D UN MOT. 14 : C 15 : C SYNTAXE 16 : C _______ 17 : C 18 : C CHARG = SEISME EVOL | BASEM | COEF MOT 19 : C | TBAS | 20 : C 21 : C REMARQUE 22 : C -------- 23 : C 24 : C AU 26/06/86 CET OPERATEUR NE FONCTIONNE QUE POUR LES 25 : C BASES MODALES.IL GENERE UN CHAMP-POINT QUI REPRESENTE LA 26 : C REPARTITION SPATIALE (SUR LES ALFA) DU CHARGEMENT SISMIQUE. 27 : C CE CHAMP MULPIPLIE PAR LA FONCTION DE TEMPS DONNE LES FORCES 28 : C GENERALISEES. 29 : C 30 : C******************************************************************* 31 : C 32 : -INC CCOPTIO 33 : -INC SMEVOLL 34 : -INC SMBASEM 35 : -INC SMCHPOI 36 : -INC SMCHARG 37 : -INC SMSOLUT 38 : C 39 : LOGICAL BASMUL,L0,L1 40 : PARAMETER (LNOM=3) 41 : CHARACTER*4 NOM(LNOM) 42 : CHARACTER*8 CTYP,TYPRET,CHARRE 43 : DATA NOM/'UX ','UY ','UZ '/ 44 : BASMUL = .FALSE. 45 : C 46 : C LECTURE DONNEES 47 : C 47 : CALL LIROBJ('EVOLUTIO',MEVOLL,1,IRETOU) 47 : CALL LIRREE(DFLOT,1,IRETOU) 48 : COEF=DFLOT 48 : CALL LIRMOT(NOM,LNOM,IMOT,1) 49 : IF (IERR.NE.0) RETURN 50 : C 51 : C CALCUL DE LA POSITION DU QN (DEPLACEMENT GENERALISE 52 : C 53 : IF (IMOT.EQ.1) THEN 54 : IPLAC=3 55 : ELSE IF (IMOT.EQ.2) THEN 56 : IPLAC=4 57 : ELSE 58 : IPLAC=5 59 : ENDIF 60 : IPLA2 = IPLAC - 2 61 : * 61 : CALL QUETYP(CTYP,1,IRETOU) 62 : * 63 : IF (CTYP(1:8).EQ.'TABLE ') THEN 63 : CALL LIRTAB('BASE_MODALE',ITBAS,0,IRET) 64 : IF (IRET.EQ.0) THEN 64 : CALL LIRTAB('ENSEMBLE_DE_BASES',ITBAS,1,IRET) 65 : BASMUL = .TRUE. 66 : ENDIF 67 : IF (IERR.NE.0) RETURN 68 : IF ( BASMUL ) THEN 69 : IB = 0 70 : 10 CONTINUE 71 : IB = IB + 1 72 : TYPRET = ' ' 72 : CALL ACCTAB(ITBAS,'ENTIER',IB,X0,' ',L0,IP0, 73 : & TYPRET,I1,X1,CHARRE,L1,ITTBAS) 74 : IF (ITTBAS.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN 74 : CALL ACCTAB(ITTBAS,'MOT',I0,X0,'MODES',L0,IP0, 75 : & 'TABLE',I1,X1,' ',L1,IBAS) 75 : CALL SEISM2(IBAS,IPLA2,ICHP2) 76 : IF (IERR.NE.0) RETURN 77 : IF (IB.EQ.1) THEN 78 : ICHPT = ICHP2 79 : ELSE 79 : CALL ADCHPO(ICHPT,ICHP2,ICHP3,1D0,1D0) 79 : CALL DECHPO(ICHPT) 79 : CALL DECHPO(ICHP2) 80 : IF (IERR.NE.0) RETURN 81 : ICHPT = ICHP3 82 : ENDIF 83 : GOTO 10 84 : ENDIF 85 : ELSE 85 : CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0, 86 : & 'TABLE',I1,X1,' ',L1,IBAS) 86 : CALL SEISM2(IBAS,IPLA2,ICHPT) 87 : IF (IERR.NE.0) RETURN 88 : ENDIF 89 : GOTO 2000 90 : ENDIF 91 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+* 92 : * version appel{e @ disparaitre 93 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+* 93 : CALL LIROBJ('BASEMODA',MBASEM,1,IRETOU) 94 : C 95 : C LECTURE DE LA BASE MODALE ET CREATION D UN CHPO DE 96 : C COMPOSANTE QN SUR FALF ASSOCIE AU MELEME DE LA BASE MODALE 97 : C 98 : SEGACT MBASEM 99 : NBAS=LISBAS(/1) 100 : NSOUPO=NBAS 101 : C 102 : NAT=1 103 : SEGINI MCHPOI 104 : C si c'est un chargement il s'agit du second membre de nature discr 105 : JATTRI(1) = 2 106 : ICHPT = MCHPOI 107 : IFOPOI=IFOUR 108 : C 109 : DO 201 NN=1,NBAS 110 : NC=1 111 : C 112 : SEGINI MSOUPO 113 : MSOBAS=LISBAS(NN) 114 : C 115 : SEGACT MSOBAS 116 : MSOLUT=IBSTRM(2) 117 : C 118 : SEGACT MSOLUT 119 : MELEME=MSOLIS(3) 120 : MSOLEN=MSOLIS(4) 121 : C 122 : SEGACT MSOLEN 123 : NBMOD=ISOLEN(/1) 124 : C 125 : N=NBMOD 126 : SEGINI MPOVAL 127 : C 128 : DO 202 NMOD=1,NBMOD 129 : MMODE=ISOLEN(NMOD) 130 : C 131 : SEGACT MMODE 132 : * 133 : * COEF EST MULTIPLIE A ICHAFO 134 : * POUR POUVOIR RECONNAITRE LE QI DE CE CHARGEMENT 135 : * LORS DE LA RECOMBINAISON DES PSEUDO-MODES. 136 : * 137 : QI = -1.D0 * FMMODD(IPLAC) 138 : VPOCHA(NMOD,1)=QI 139 : SEGDES MMODE 140 : 202 CONTINUE 141 : C 142 : SEGDES MPOVAL 143 : IPOVAL=MPOVAL 144 : NOHARM(1)=NIFOUR 145 : NOCOMP(1)='FALF' 146 : IGEOC=MELEME 147 : SEGDES MSOUPO 148 : C 149 : IPCHP(NN)=MSOUPO 150 : SEGDES MSOBAS,MSOLUT,MSOLEN 151 : 201 CONTINUE 152 : C 153 : SEGDES MBASEM 154 : C 155 : SEGDES MCHPOI 156 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+* 157 : 2000 CONTINUE 158 : C 159 : C CREATION DU CHARG. EN ASSOCIANT AU CHPO LA FONCTION DE TEMPS 160 : C L OBJET EVOLUTION 161 : C 162 : N=1 163 : SEGINI MCHARG 164 : SEGINI ICHARG 165 : SEGACT MEVOLL 166 : KEVOLL=IEVOLL(1) 167 : SEGACT KEVOLL 168 : CHANAT(1)='FORCE' 169 : CHANOM(1) = ' 1' 170 : CHAMOB(1)='STAT' 171 : CHALIE(1)='LIE ' 172 : CHATYP = 'CHPOINT ' 173 : ICHPO1=ICHPT 174 : ICHPO2=IPROGX 175 : IPPP = IPROGY 175 : CALL MUFLIR(IPPP,COEF,IPY,1) 176 : ICHPO3=IPY 177 : c ICHPO4, ICHPO5, ICHPO6 et ICHPO7 ne sont pas initialises 178 : SEGDES KEVOLL,MEVOLL 179 : SEGDES ICHARG 180 : KCHARG(1)=ICHARG 181 : SEGDES MCHARG 182 : C 182 : CALL ECROBJ('CHARGEME',MCHARG) 183 : C 184 : END 185 : 186 : 187 :
© Cast3M 2003 - All rights reserved.
Disclaimer