Télécharger psreco.eso

Retour à la liste

Numérotation des lignes :

  1. C PSRECO SOURCE BP208322 15/06/22 21:21:30 8543
  2. SUBROUTINE PSRECO(IMODE,IPSMO,TYPE,ICHAR,ICHLIA,TEMPS,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,Q-Z)
  5. ************************************************************************
  6. *
  7. * P S R E C O
  8. * -----------
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * AJOUTE LA CONTRIBUTIONN DUE AUX MODES NEGLIGES.
  14. *
  15. * MODULES UTILISES:
  16. * -----------------
  17. *
  18. -INC CCHAMP
  19. -INC CCOPTIO
  20. -INC CCREEL
  21. *-
  22. -INC SMATTAC
  23. -INC SMCHARG
  24. -INC SMCHPOI
  25. -INC SMELEME
  26. -INC SMLREEL
  27. -INC SMSOLUT
  28. *
  29. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  30. * -----------
  31. *
  32. * IMODE (E) OBJET SOLUTION DE SOUS-TYPE MODE.
  33. * IPSMO (E) OBJET SOLUTION DE SOUS-TYPE PSEUMODE.
  34. * TYPE (E) DEPL OU CONT.
  35. * ICHAR (E) POINTEUR SUR LE CHARGEMENT.
  36. * ICHLIA (E) CHPOINT DES FORCES DE LIAISON.
  37. * TEMPS (E) TEMPS DE LA RECOMBINAISON.
  38. * IRET (E) POINTEUR SUR LE CHPOINT DE RECOMBINAISON.
  39. * (S) POINTEUR SUR LE CHPOINT DE RECOMBINAISON.
  40. *
  41. CHARACTER*4 TYPE
  42. *
  43. * VARIABLES:
  44. * ----------
  45. *
  46. CHARACTER*4 COMP,CC,MONTYP,DIRECT
  47. PARAMETER (TOLER = 1.D-6)
  48. *
  49. *
  50. * AUTEUR, DATE DE CREATION:
  51. * -------------------------
  52. *
  53. * LIONEL VIVAN SEPTEMBRE 1988
  54. *
  55. * LANGAGE:
  56. * --------
  57. *
  58. * ESOPE + FORTRAN77
  59. *
  60. * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 02/91
  61. *
  62. ************************************************************************
  63. *
  64. IF (IPSMO.EQ.0) THEN
  65. CALL ERREUR(429)
  66. RETURN
  67. ENDIF
  68. *
  69. IF (ICHAR.EQ.0 .AND. ICHLIA.EQ.0) THEN
  70. CALL ERREUR(430)
  71. RETURN
  72. ENDIF
  73. *
  74. IF (TEMPS.LT.XPETIT) THEN
  75. CALL ERREUR(431)
  76. RETURN
  77. ENDIF
  78. *
  79. MSOLUT = IPSMO
  80. SEGACT MSOLUT
  81. *
  82. MSOLEN = MSOLIS(10)
  83. SEGACT MSOLEN
  84. NPS = ISOLEN(/1)
  85. *
  86. IF (TYPE.EQ.'DEPL') THEN
  87. MSOLE1 = MSOLIS(5)
  88. ELSE IF (TYPE.EQ.'CONT') THEN
  89. MSOLE1 = MSOLIS(6)
  90. ELSE
  91. GOTO 9000
  92. ENDIF
  93. *
  94. IF (MSOLE1.EQ.0) THEN
  95. * MANQUE LES DEPLACEMENTS OU LES CONTRAINTES
  96. IF (TYPE.EQ.'DEPL') THEN
  97. MOTERR(1:12) = 'DEPLACEMENTS'
  98. ELSE
  99. MOTERR(1:12) = 'CONTRAINTES '
  100. ENDIF
  101. CALL ERREUR(427)
  102. GOTO 9000
  103. ENDIF
  104. SEGACT MSOLE1
  105. *
  106. IF (ICHAR.NE.0) THEN
  107. MCHARG = ICHAR
  108. SEGACT MCHARG
  109. NCH = KCHARG(/1)
  110. ENDIF
  111. *
  112. DO 10 IP = 1,NPS
  113. MJONCT = ISOLEN(IP)
  114. SEGACT MJONCT
  115. MONTYP = MJOTYP
  116. *
  117. * PSEUDO-MODE D'UNE STRUCTURE MULTISUPPORTEE
  118. *
  119. IF (MONTYP.EQ.'DEPL') THEN
  120. IF (ICHAR.EQ.0) THEN
  121. SEGDES MJONCT
  122. GOTO 10
  123. ENDIF
  124. ICHM = IPCHJO(1)
  125. * RECHERCHE DU CHARGEMENT
  126. DO 12 IC = 1,NCH
  127. ICHARG = KCHARG(IC)
  128. SEGACT ICHARG
  129. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT'
  130. & .OR.CHALIE(IC).NE.'LIE ') THEN
  131. SEGDES ICHARG
  132. GOTO 12
  133. ENDIF
  134. ICHC = ICHPO1
  135. IF (ICHC.EQ.ICHM) THEN
  136. * ON A TROUVE LE CHARGEMENT
  137. GOTO 100
  138. ENDIF
  139. SEGDES ICHARG
  140. 12 CONTINUE
  141. *
  142. * IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE
  143. *
  144. INTERR(1) = IP
  145. CALL ERREUR(428)
  146. SEGDES MJONCT
  147. GOTO 10
  148. *
  149. * PSEUDO-MODE D'UNE FORCE CONCENTREE
  150. *
  151. ELSE IF (MONTYP.EQ.'FORC') THEN
  152. IF (ICHAR.EQ.0) THEN
  153. SEGDES MJONCT
  154. GOTO 10
  155. ENDIF
  156. ICHM = IPCHJO(1)
  157. * RECHERCHE DU CHARGEMENT
  158. DO 22 IC = 1,NCH
  159. ICHARG = KCHARG(IC)
  160. SEGACT ICHARG
  161. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT'
  162. & .OR.CHALIE(IC).NE.'LIE ') THEN
  163. SEGDES ICHARG
  164. GOTO 22
  165. ENDIF
  166. ICHC = ICHPO1
  167. IF (ICHC.EQ.ICHM) THEN
  168. * ON A TROUVE LE CHARGEMENT
  169. GOTO 100
  170. ENDIF
  171. SEGDES ICHARG
  172. 22 CONTINUE
  173. *
  174. * IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE
  175. *
  176. INTERR(1) = IP
  177. CALL ERREUR(428)
  178. SEGDES MJONCT
  179. GOTO 10
  180. *
  181. * PSEUDO-MODE D'UNE EXCITATION SISMIQUE D'ENSEMBLE
  182. *
  183. ELSE IF (MONTYP.EQ.'SEIS') THEN
  184. IF (ICHAR.EQ.0) THEN
  185. SEGDES MJONCT
  186. GOTO 10
  187. ENDIF
  188. DIRECT = MJODDL
  189. IF (DIRECT.EQ.'UX ') THEN
  190. IPLAC = 3
  191. ELSE IF (DIRECT.EQ.'UY ') THEN
  192. IPLAC = 4
  193. ELSE
  194. IPLAC = 5
  195. ENDIF
  196. MSO1 = IMODE
  197. SEGACT MSO1
  198. MSOLE2 = MSO1.MSOLIS(4)
  199. SEGDES MSO1
  200. SEGACT MSOLE2
  201. MMODE = MSOLE2.ISOLEN(1)
  202. SEGDES MSOLE2
  203. SEGACT MMODE
  204. QPS = FMMODD(IPLAC)
  205. QPS = -1.D0 * QPS
  206. SEGDES MMODE
  207. * RECHERCHE DU CHARGEMENT
  208. DO 32 IC = 1,NCH
  209. ICHARG = KCHARG(IC)
  210. SEGACT ICHARG
  211. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT'
  212. & .OR.CHALIE(IC).NE.'LIE ') THEN
  213. SEGDES ICHARG
  214. GOTO 32
  215. ENDIF
  216. MCHPOI = ICHPO1
  217. SEGACT MCHPOI
  218. MSOUPO = IPCHP(1)
  219. SEGDES MCHPOI
  220. SEGACT MSOUPO
  221. MPOVAL = IPOVAL
  222. SEGDES MSOUPO
  223. SEGACT MPOVAL
  224. QXYZ = VPOCHA(1,1)
  225. SEGDES MPOVAL
  226. EPS = ABS(QPS - QXYZ)
  227. IF (EPS.LT.TOLER) THEN
  228. * ON A TROUVE LE CHARGEMENT
  229. GOTO 100
  230. ENDIF
  231. SEGDES ICHARG
  232. 32 CONTINUE
  233. *
  234. * IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE
  235. *
  236. INTERR(1) = IP
  237. CALL ERREUR(428)
  238. SEGDES MJONCT
  239. GOTO 10
  240. *
  241. * PSEUDO-MODE D'UNE FORCE DE CHOC
  242. *
  243. ELSE IF (MONTYP.EQ.'CHOC') THEN
  244. IF (ICHLIA.EQ.0) THEN
  245. SEGDES MJONCT
  246. GOTO 10
  247. ENDIF
  248. GOTO 100
  249. ENDIF
  250. *
  251. 100 CONTINUE
  252. ICHP = MSOLE1.ISOLEN(IP)
  253. *
  254. IF (MONTYP.EQ.'CHOC') THEN
  255. IPOINP = MJOPOI
  256. COMP = MJODDL
  257. CALL ECROBJ('POINT ',IPOINP)
  258. CALL ECRCHA(COMP)
  259. CALL ECROBJ('CHPOINT ',ICHLIA)
  260. CALL EXTRAI
  261. CALL LIRREE(FTEMPS,1,IRETOU)
  262. IF (IERR.NE.0) RETURN
  263. ELSE
  264. FTEMPS = 0.D0
  265. MLREE1 = ICHPO2
  266. SEGACT MLREE1
  267. NF = MLREE1.PROG(/1)
  268. MLREE2 = ICHPO3
  269. SEGACT MLREE2
  270. N1 = 1
  271. N2 = 2
  272. CALL INTLIN(TEMPS,ICHPO2,ICHPO3,NF,N1,N2,FT0,IRETOU)
  273. IF (IRETOU.EQ.0) THEN
  274. INTERR(1) = IP
  275. CALL ERREUR(428)
  276. GOTO 10
  277. ENDIF
  278. FTEMPS = FT0
  279. SEGDES MLREE1
  280. SEGDES MLREE2
  281. SEGDES ICHARG
  282. ENDIF
  283. *
  284. IF (IIMPI.EQ.1804) THEN
  285. PRINT*,'-- prise en compte des pseudo-modes -- FTEMPS :',FTEMPS
  286. ENDIF
  287. *
  288. N1 = 1
  289. IF (TYPE.EQ.'DEPL') THEN
  290. CALL ADCHPO(IRET,ICHP,IRET,1D0,FTEMPS)
  291. ELSE
  292. IPCHE1 = ICHP
  293. IF (IP.EQ.1) IPRET = IRET
  294. *
  295. CALL MUCHEL(IPCHE1,FTEMPS,ICHP1,N1)
  296. CALL ADCHEL(IPRET,ICHP1,IPRET,N1)
  297. CALL DTCHAM(ICHP1)
  298. ENDIF
  299. SEGDES MJONCT
  300. *
  301. 10 CONTINUE
  302. *
  303. SEGDES MSOLE1
  304. IF (ICHAR.NE.0) THEN
  305. SEGDES MCHARG
  306. ENDIF
  307. *
  308. 9000 CONTINUE
  309. SEGDES MSOLEN
  310. SEGDES MSOLUT
  311.  
  312. RETURN
  313. END
  314.  
  315.  
  316.  
  317.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales