Télécharger basemd.eso

Retour à la liste

Numérotation des lignes :

  1. C BASEMD SOURCE BP208322 15/06/22 21:15:18 8543
  2. SUBROUTINE BASEMD
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C
  6. C ==================================================================
  7. C C
  8. C C CREATION D UNE BASE MODALE
  9. C C SYNTAXE : B = BASE S L M U V ;
  10. C C B : OBJET DE TYPE BASE MODALE
  11. C C S : OBJET DE TYPE STRUCTURE
  12. C C L : OBJET DE TYPE MATTAC
  13. C C M : OBJET DE TYPE SOLUTION (SOUS TYPE : MODES)
  14. C C U : OBJET DE TYPE SOLUTION (SOUS TYPE : SOLUTIONS STATIQUES)
  15. C C V : OBJET DE TYPE SOLUTION (SOUS TYPE : PSEUMODE)
  16. C C
  17. C C ECRIT PAR FARVACQUE.
  18. C C APPELLE LES SUBROUTINES SUIVANTS:
  19. C C LIRE,ECRIRE,SOLS1,ERREUR(61,130,131,133,134,135,173,226,227)
  20. C ==================================================================
  21. C
  22. -INC SMSOLUT
  23. -INC SMBASEM
  24. -INC SMSTRUC
  25. -INC SMATTAC
  26. -INC CCOPTIO
  27. -INC CCHAMP
  28. -INC CCREEL
  29. -INC SMCOORD
  30. -INC SMELEME
  31. SEGMENT ITRAV(NJONC)
  32. SEGMENT ITRABB(0)
  33. *
  34. PARAMETER ( LNOM1 = 2 )
  35. CHARACTER*4 NOMOP1(LNOM1)
  36. CHARACTER*8 CTYP
  37. DATA NOMOP1/'PLUS','ROTA'/
  38. *
  39. * Nouvelle version avec les TABLEs
  40. *
  41. CALL LIRMOT(NOMOP1,LNOM1,IMOT1,0)
  42. IF(IERR.NE.0) RETURN
  43. CALL QUETYP(CTYP,1,IRETOU)
  44. IF (CTYP(1:8).EQ.'TABLE ') THEN
  45. CALL LIRTAB('BASE_MODALE',ITBAS,1,IRETOU)
  46. IF(IERR.NE.0) RETURN
  47. CALL LIRTAB('POINT',ITPTS,1,IRETOU)
  48. IF(IERR.NE.0) RETURN
  49. IPO1 = 0
  50. IPO2 = 0
  51. XANG = XZERO
  52. CALL LIROBJ('POINT ',IPO1,1,IRETOU)
  53. IF(IERR.NE.0) RETURN
  54. IF (IMOT1.EQ.2) THEN
  55. IF (IDIM.EQ.3) THEN
  56. CALL LIROBJ('POINT ',IPO2,1,IRETOU)
  57. IF(IERR.NE.0) RETURN
  58. ENDIF
  59. CALL LIRREE(XANG,1,IRETOU)
  60. IF(IERR.NE.0) RETURN
  61. ENDIF
  62. IF (IMOT1.EQ.0) THEN
  63. CALL ERREUR(498)
  64. RETURN
  65. ELSE
  66. CALL COPBAS(ITBAS,ITPTS,NOMOP1(IMOT1),IPO1,IPO2,XANG)
  67. RETURN
  68. ENDIF
  69. ENDIF
  70. C
  71. NIBST=5
  72. C
  73. C **** LECTURE DE LA STRUCTURE
  74. C
  75. CALL LIROBJ('STRUCTUR',ISTRU0,1,IRETOU)
  76. IF(IERR.NE.0) GO TO 5000
  77. MSTRUC=ISTRU0
  78. SEGACT MSTRUC
  79. NSTRU=LISTRU(/1)
  80. IF(NSTRU.NE.1) THEN
  81. C ON VERIFIE QUE LA STRUCTURE EST IDENTIQUE
  82. MSOSTU=LISTRU(1)
  83. SEGACT MSOSTU
  84. I1=ISRAID
  85. I2=ISMASS
  86. I3=ITYSOU
  87. SEGDES MSOSTU
  88. DO 5 I=2,NSTRU
  89. MSOSTU=LISTRU(I)
  90. SEGACT MSOSTU
  91. IF(ISRAID.NE.I1) GOTO 6
  92. IF(ISMASS.NE.I2) GOTO 6
  93. IF(ITYSOU.NE.I3) GOTO 6
  94. SEGDES MSOSTU
  95. GOTO 5
  96. 6 CONTINUE
  97. SEGDES MSOSTU
  98. CALL ERREUR(226)
  99. C LES SOUS STRUCTURES NE SONT PAS IDENTIQUES
  100. GOTO 5000
  101. 5 CONTINUE
  102. ENDIF
  103. SEGDES MSTRUC
  104. C
  105. C **** LECTURE DU MATTAC
  106. C
  107. CALL LIROBJ('ATTACHE ',IRET,0,IRETOU)
  108. MATTAC=IRET
  109. IF(IRETOU.EQ.0) MATTAC=0
  110. C
  111. C **** LECTURE DES OBJETS SOLUTION
  112. C
  113. IMODE=0
  114. ISOLS=0
  115. IPSMO = 0
  116. 1 CALL LIROBJ('SOLUTION',IRET,0,IRETOU)
  117. IF(IRETOU.EQ.0) GO TO 53
  118. MSOLUT=IRET
  119. SEGACT MSOLUT
  120. C
  121. C **** EST CE UN MODE ?
  122. C
  123. IF(ITYSOL.NE.'MODE ') GO TO 51
  124. IF(IMODE.EQ.0) GO TO 52
  125. MOTERR(1:8)='SOLUTION'
  126. MOTERR(9:15)='MODE'
  127. CALL ERREUR(130)
  128. C MODES DEJA DONNES
  129. SEGDES MSOLUT
  130. GO TO 5000
  131. 52 CONTINUE
  132. IMODE=MSOLUT
  133. SEGACT MSOLUT
  134. MSOLEN=MSOLIS(5)
  135. SEGDES MSOLUT
  136. IF(MSOLEN.NE.0) GO TO 304
  137. MOTERR(1:8)='MODE'
  138. CALL ERREUR(61)
  139. GOTO 5000
  140. 304 CONTINUE
  141. IF(ISOLS.EQ.0) GO TO 1
  142. GO TO 53
  143. 51 CONTINUE
  144. C
  145. C **** EST CE UN SOLSTA ?
  146. C
  147. IF(ITYSOL.NE.'SOLUSTAT') GO TO 54
  148. IF(ISOLS.EQ.0) GO TO 55
  149. MOTERR(1:8)='SOLUTION'
  150. MOTERR(9:16)='SOLUSTAT'
  151. CALL ERREUR(130)
  152. C SOLUTIONS STATIQUES DEJA DONNEES
  153. SEGDES MSOLUT
  154. GO TO 5000
  155. 55 CONTINUE
  156. ISOLS=MSOLUT
  157. SEGDES MSOLUT
  158. IF(IMODE.EQ.0) GO TO 1
  159. GO TO 53
  160. C
  161. C **** EST CE UN PSEUMOD?
  162. C
  163. 54 CONTINUE
  164. IF(ITYSOL.NE.'PSEUMODE') GO TO 954
  165. IF(IPSMO.EQ.0) GO TO 955
  166. MOTERR(1:8)='SOLUTION'
  167. MOTERR(9:16)='PSEUMODE'
  168. CALL ERREUR(130)
  169. C SOLUTIONS STATIQUES DEJA DONNEES
  170. SEGDES MSOLUT
  171. GO TO 5000
  172. 955 CONTINUE
  173. IPSMO=MSOLUT
  174. SEGDES MSOLUT
  175. IF(IMODE.EQ.0) GO TO 1
  176. GO TO 53
  177. 954 CONTINUE
  178. MOTERR(1:8)='SOLUTION'
  179. MOTERR(9:16)=ITYSOL
  180. CALL ERREUR(131)
  181. C ON N ATTEND PAS CE SOUSTYPE DE SOLUTION
  182. SEGDES MSOLUT
  183. GO TO 5000
  184. C
  185. C **** VERIFICATIONS DIVERSES
  186. C
  187. 53 CONTINUE
  188. IF(IMODE.NE.0 . OR . MATTAC.NE.0) GO TO 60
  189. CALL ERREUR(133)
  190. C NI MODE NI LIAISON DANS CETTE BASE MODALE
  191. GO TO 5000
  192. 60 CONTINUE
  193. C
  194. SEGACT MSTRUC
  195. C BOUCLE SUR LES SOUS-BASES
  196. SEGINI ITRABB
  197. DO 66 IBAS=1,NSTRU
  198. SEGINI MSOBAS
  199. ITRABB(**)=MSOBAS
  200. IBSTRM(1)=LISTRU(IBAS)
  201. IBSTRM(2)=0
  202. IBSTRM(3)=0
  203. IBSTRM(4)=MATTAC
  204. IBSTRM(5)=IPSMO
  205. IF(IBAS.EQ.1) THEN
  206. IBSTRM(2)=IMODE
  207. ELSE IF(IMODE.NE.0) THEN
  208. C
  209. C **** DANS LE CAS IDEN, DUPLICATION DES MODES
  210. C
  211. SEGACT MCOORD
  212. MSOLUT=IMODE
  213. SEGACT MSOLUT
  214. MELEME=MSOLIS(3)
  215. SEGACT MELEME
  216. NBELEM=NUM(/2)
  217. NBREF=0
  218. NBNN=1
  219. NBSOUS=0
  220. SEGINI IPT1
  221. ITYPEL=1
  222. MSOSTU=LISTRU(IBAS)
  223. IPOIN=XCOOR(/1)/(IDIM+1)
  224. NBPTS=IPOIN+NBELEM
  225. SEGADJ MCOORD
  226. DO 403 I=1,NBELEM
  227. XCOOR(IPOIN*(IDIM+1)+1)=0.
  228. XCOOR(IPOIN*(IDIM+1)+2)=0.
  229. IF(IDIM.EQ.3) XCOOR(IPOIN*(IDIM+1)+3)=0.
  230. XCOOR(IPOIN*(IDIM+1)+(IDIM+1))=0.
  231. IPOIN=IPOIN+1
  232. IPT1.NUM(1,I)=IPOIN
  233. 403 CONTINUE
  234. NIPO=MSOLIS(/1)
  235. SEGINI MSO1
  236. MSO1.ITYSOL=ITYSOL
  237. DO 404 I=1,NIPO
  238. MSO1.MSOLIS(I)=MSOLIS(I)
  239. MSO1.MSOLIT(I)=MSOLIT(I)
  240. 404 CONTINUE
  241. MSO1.MSOLIS(3)=IPT1
  242. SEGDES MSO1,MSOLUT,MELEME,IPT1
  243. IBSTRM(2)=MSO1
  244. ENDIF
  245. C
  246. C **** BOUCLE SUR LES LIAISONS : ON CHERCHE LES LIAISONS QUI AGISSENT
  247. C **** SUR MSOSTU. MECA, FLUIDE ET DEPI :MJONCT MIS DANS MSOLE1
  248. C **** AUTRES :RIEN
  249. C
  250. IF(MATTAC.EQ.0) GO TO 61
  251. N=0
  252. SEGACT MATTAC
  253. MSOSTU=LISTRU(IBAS)
  254. NSOUMA=LISATT(/1)
  255. DO 70 IA=1,NSOUMA
  256. MSOUMA=LISATT(IA)
  257. SEGACT MSOUMA
  258. NL=IATREL(/1)
  259. DO 72 IB=1,NL
  260. MJONCT=IATREL(IB)
  261. SEGACT MJONCT
  262. NC=ISTRJO(/1)
  263. DO 73 IC=1,NC
  264. IF(ISTRJO(IC).NE.MSOSTU) GO TO 73
  265. IF(ITYATT.NE.'MECA'.AND.ITYATT.NE.'FLUI'.AND.ITYATT.NE.'DEPI')
  266. & GOTO 73
  267. N=N+1
  268. IF(N.EQ.1)SEGINI MSOLE1
  269. IF(N.NE.1)SEGADJ MSOLE1
  270. MSOLE1.ISOLEN(N)=MJONCT
  271. C WRITE(6,4446)MJONCT
  272. C4446 FORMAT(' ********MJONCT=',I6)
  273. 73 CONTINUE
  274. SEGDES MJONCT
  275. 72 CONTINUE
  276. SEGDES MSOUMA
  277. 70 CONTINUE
  278. NJONC=N
  279. C
  280. IF(ISOLS.NE.0) THEN
  281. C
  282. C **** COMPATIBILITE ENTRE LES MJONCT ET LES SOLUTIONS STATIQUES?
  283. C
  284. IF(NJONC.EQ.0) GOTO 900
  285. C INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
  286. MSOLUT=ISOLS
  287. SEGACT MSOLUT
  288. MSOLEN=MSOLIS(10)
  289. SEGACT MSOLEN
  290. LTAB=ISOLEN(/1)
  291. IF(LTAB.LT.NJONC) THEN
  292. C INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
  293. SEGDES MSOLEN,MSOLUT
  294. GO TO 900
  295. ENDIF
  296. IF(NJONC.LT.LTAB) SEGINI ITRAV
  297. DO 81 J=1,NJONC
  298. MJONCT=MSOLE1.ISOLEN(J)
  299. DO 80 I=1,LTAB
  300. IF(MJONCT.NE.ISOLEN(I)) GO TO 80
  301. IF(NJONC.LT.LTAB) ITRAV(J)=I
  302. GOTO 81
  303. 80 CONTINUE
  304. C INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
  305. SEGDES MSOLEN,MSOLUT
  306. IF(NJONC.LT.LTAB) SEGSUP ITRAV
  307. GO TO 900
  308. 81 CONTINUE
  309. SEGDES MSOLEN,MSOLUT
  310. IF(NJONC.LT.LTAB) THEN
  311. C
  312. C CREATION DE L'OBJET SOLUTION STATIQUE REDUIT AUX LIAISONS DU MATTAC
  313. C
  314. MSO1=ISOLS
  315. SEGACT MSO1
  316. MSOLE2=MSO1.MSOLIS(5)
  317. SEGACT MSOLE2
  318. N=NJONC
  319. SEGINI MSOLEN
  320. NBELEM=NJONC
  321. NBNN=1
  322. NBSOUS=0
  323. NBREF=0
  324. SEGINI MELEME
  325. ITYPEL=1
  326. DO 82 IB=1,NJONC
  327. MJONCT=MSOLE1.ISOLEN(IB)
  328. SEGACT MJONCT
  329. IPT1=MJOPOI
  330. SEGACT IPT1
  331. NUM(1,IB)=IPT1.NUM(1,ITRAV(IB))
  332. ISOLEN(IB)=MSOLE2.ISOLEN(ITRAV(IB))
  333. SEGDES IPT1,MJONCT
  334. 82 CONTINUE
  335. SEGDES MELEME,MSOLE2,MSOLEN,MSOLE1
  336. SEGSUP ITRAV
  337. NIPO=10
  338. SEGINI MSOLUT
  339. ITYSOL='SOLUSTAT'
  340. DO 83 I=1,NIPO
  341. MSOLIS(I)=0
  342. MSOLIT(I)=0
  343. 83 CONTINUE
  344. MSOLIS(3)=MELEME
  345. MSOLIS(5)=MSOLEN
  346. MSOLIT(5)=2
  347. MSOLIT(10)=14
  348. MSOLIS(10)=MSOLE1
  349. SEGDES MSOLUT
  350. IBSTRM(3)=MSOLUT
  351. ELSE
  352. IBSTRM(3)=ISOLS
  353. SEGSUP MSOLE1
  354. ENDIF
  355. ELSE
  356. C
  357. C *** IL N'Y A PAS DE SOLUTION STATIQUES. S'IL EN FAUT ON VA LES
  358. C *** CALCULER EN APPELANT LE SOUS-PROGRAMME SOLS1 DE L'OPERATEUR SOLS
  359. C
  360. IF(NJONC.NE.0) THEN
  361. KSOSTU=MSOSTU
  362. KSOLE1=MSOLE1
  363. CALL SOLS1(KSOSTU,KSOLE1,KSOLUT)
  364. IF(IERR.NE.0) THEN
  365. SEGSUP MSOLE1
  366. GOTO 900
  367. ENDIF
  368. IBSTRM(3)=KSOLUT
  369. ENDIF
  370. ENDIF
  371. C
  372. C **** SI IL Y A D'AUTRES TYPES DE LIAISONS, ON CREE DES MODES ET DES
  373. C **** SOLUTIONS STATIQUES REDUITS AUX POINTS DE CES DERNIERES LIAISONS
  374. C
  375. IF(IMODE.EQ.0) THEN
  376. C *** OUBLI DES MODES
  377. CALL ERREUR(227)
  378. ENDIF
  379. GOTO 62
  380. C
  381. 900 CONTINUE
  382. MOTERR(1:8)='SOLUSTAT'
  383. MOTERR(9:15)='ATTACHE'
  384. CALL ERREUR(135)
  385. 62 CONTINUE
  386. SEGDES MATTAC
  387. 61 CONTINUE
  388. SEGDES MSOBAS
  389. 66 CONTINUE
  390. SEGDES MSTRUC
  391. N=ITRABB(/1)
  392. IF(N.NE.0) THEN
  393. SEGINI MBASEM
  394. DO 800 NN=1,N
  395. LISBAS(NN)=ITRABB(NN)
  396. 800 CONTINUE
  397. SEGDES MBASEM
  398. CALL ECROBJ('BASEMODA',MBASEM)
  399. ENDIF
  400. SEGSUP ITRABB
  401. 5000 CONTINUE
  402. RETURN
  403. END
  404.  
  405.  
  406.  
  407.  
  408.  
  409.  
  410.  

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