Télécharger relr30.eso

Retour à la liste

Numérotation des lignes :

  1. C RELR30 SOURCE PV 16/11/17 22:01:18 9180
  2. SUBROUTINE RELR30(MATASS,MCHPOI,
  3. $ MCON,MCHPO2,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : RELR30
  9. C DESCRIPTION :
  10. *
  11. * Création d'une matrice de contraintes (simple mulag)
  12. *
  13. C
  14. C
  15. C
  16. C LANGAGE : ESOPE
  17. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  18. C mél : gounand@semt2.smts.cea.fr
  19. C***********************************************************************
  20. C APPELES :
  21. C APPELES (E/S) :
  22. C APPELES (BLAS) :
  23. C APPELES (CALCUL) :
  24. C APPELE PAR :
  25. C***********************************************************************
  26. C SYNTAXE GIBIANE :
  27. C ENTREES :
  28. C ENTREES/SORTIES :
  29. C SORTIES :
  30. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  31. C***********************************************************************
  32. C VERSION : v1, 01/03/2006, version initiale
  33. C HISTORIQUE : v1, 01/03/2006, création
  34. C HISTORIQUE :
  35. C HISTORIQUE :
  36. C***********************************************************************
  37. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  38. C en cas de modification de ce sous-programme afin de faciliter
  39. C la maintenance !
  40. C***********************************************************************
  41. -INC CCOPTIO
  42. -INC SMCOORD
  43. -INC CCHAMP
  44. -INC SMCHPOI
  45. -INC TMTRAV
  46. POINTEUR MTRA2.MTRAV
  47. -INC SMRIGID
  48. POINTEUR MCON.MRIGID
  49. POINTEUR DESCON.DESCR
  50. * POINTEUR ICON.IMATRI
  51. POINTEUR XCON.XMATRI
  52. -INC SMELEME
  53. POINTEUR MEL.MELEME
  54. * Includes persos
  55. CBEGININCLUDE SMMINC
  56. SEGMENT MINC
  57. INTEGER NPOS(NPT+1)
  58. INTEGER MPOS(NPT,NBI+1)
  59. ENDSEGMENT
  60. SEGMENT IMINC
  61. INTEGER LNUPO (NDDL)
  62. INTEGER LNUINC(NDDL)
  63. ENDSEGMENT
  64. CENDINCLUDE SMMINC
  65. POINTEUR MINCP.MINC
  66. POINTEUR MINCD.MINC
  67. POINTEUR IMINCP.IMINC
  68. POINTEUR IMINCD.IMINC
  69. CBEGININCLUDE SMPMORS
  70. SEGMENT PMORS
  71. INTEGER IA (NTT+1)
  72. INTEGER JA (NJA)
  73. ENDSEGMENT
  74. CENDINCLUDE SMPMORS
  75. POINTEUR PROFM.PMORS
  76. CBEGININCLUDE SMIZA
  77. SEGMENT IZA
  78. REAL*8 A(NBVA)
  79. ENDSEGMENT
  80. CENDINCLUDE SMIZA
  81. POINTEUR VALM.IZA
  82. CBEGININCLUDE SMMATASS
  83. SEGMENT MATASS
  84. POINTEUR KJPOPA.MLENTI
  85. POINTEUR LINCPA.MLMOTS
  86. POINTEUR MINCPA.MINC
  87. POINTEUR KJPODA.MLENTI
  88. POINTEUR LINCDA.MLMOTS
  89. POINTEUR MINCDA.MINC
  90. POINTEUR PROFMA.PMORS
  91. POINTEUR VALMA.IZA
  92. ENDSEGMENT
  93. CENDINCLUDE SMMATASS
  94. *
  95. -INC SMLENTI
  96. POINTEUR KJSPGP.MLENTI
  97. POINTEUR KJSPGD.MLENTI
  98. POINTEUR KLSPGP.MLENTI
  99. POINTEUR KKSPGP.MLENTI
  100. -INC SMLMOTS
  101. POINTEUR LINCP.MLMOTS
  102. POINTEUR LINCD.MLMOTS
  103. *
  104. INTEGER IMPR,IRET
  105. CHARACTER*4 MYMOP,MYMOD
  106. *
  107. * Executable statements
  108. *
  109. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr30.eso'
  110. *
  111. * Lecture de MATASS
  112. *
  113. SEGACT MATASS
  114. KJSPGP=MATASS.KJPOPA
  115. LINCP =MATASS.LINCPA
  116. MINCP =MATASS.MINCPA
  117. KJSPGD=MATASS.KJPODA
  118. LINCD =MATASS.LINCDA
  119. MINCD =MATASS.MINCDA
  120. PROFM =MATASS.PROFMA
  121. VALM =MATASS.VALMA
  122. *
  123. * Création de l'inverse des segments MINC
  124. * et suppression de ces derniers
  125. *
  126. * In relr21 : SEGINI IMINCP
  127. CALL RELR21(MINCP,IMINCP,IMPR,IRET)
  128. IF (IRET.NE.0) GOTO 9999
  129. * In relr21 : SEGINI IMINCD
  130. CALL RELR21(MINCD,IMINCD,IMPR,IRET)
  131. IF (IRET.NE.0) GOTO 9999
  132. * SEGPRT,IMINCP
  133. * SEGPRT,IMINCD
  134. SEGSUP MINCP
  135. SEGSUP MINCD
  136. * SEGDES MCOORD
  137. SEGACT MCOORD*MOD
  138. SEGACT KJSPGP
  139. SEGACT LINCP
  140. SEGACT IMINCP
  141. SEGACT KJSPGD
  142. SEGACT LINCD
  143. SEGACT IMINCD
  144. SEGACT PROFM
  145. SEGACT VALM
  146. NDDLDU=IMINCD.LNUPO(/1)
  147. NPOPRI=KJSPGP.LECT(/1)
  148. * Il y a autant de rigidités à créer que de degrés de liberté duaux
  149. NRIGEL=NDDLDU
  150. SEGINI MCON
  151. MCON.MTYMAT='CON.DIV.'
  152. JG=NPOPRI
  153. SEGINI KLSPGP
  154. IF (MCHPOI.NE.0) THEN
  155. * Transformer le KJSPGD en MELEME
  156. NBNN=1
  157. NBELEM=KJSPGD.LECT(/1)
  158. NBSOUS=0
  159. NBREF=0
  160. SEGINI MELEME
  161. DO IBELEM=1,NBELEM
  162. NUM(1,IBELEM)=KJSPGD.LECT(IBELEM)
  163. ENDDO
  164. * In CP2TR2 : SEGDES LINCD
  165. CALL CP2TR2(LINCD,MELEME,MCHPOI,MTRAV,IRET)
  166. IF (IRET.NE.0) GOTO 9999
  167. SEGSUP MELEME
  168. SEGACT MTRAV
  169. SEGACT LINCD
  170. NNIN=LINCD.MOTS(/2)
  171. NNNOE=NDDLDU
  172. SEGINI MTRA2
  173. DO ININ=1,NNIN
  174. MTRA2.INCO(ININ)=LINCD.MOTS(ININ)
  175. MTRA2.NHAR(ININ)=MTRAV.NHAR(ININ)
  176. ENDDO
  177. ENDIF
  178. * Ensemble des numéros de points primaux
  179. DO IDDLDU=1,NDDLDU
  180. MCON.COERIG(IDDLDU)=1.D0
  181. INZ=PROFM.IA(IDDLDU)
  182. LNZ=PROFM.IA(IDDLDU+1)-INZ
  183. *
  184. * Création de la géométrie pour la iddldueme matrice
  185. *
  186. * Quels points de KJSPGP sont concernés par les
  187. * ddls INZ à INZ+LNZ-1.
  188. * degré et fin de la liste chaînée
  189. LDG=0
  190. LAST=-1
  191. DO JNZ=1,LNZ
  192. NUMPP=IMINCP.LNUPO(PROFM.JA(INZ+JNZ-1))
  193. IF (KLSPGP.LECT(NUMPP).EQ.0) THEN
  194. LDG=LDG+1
  195. KLSPGP.LECT(NUMPP)=LAST
  196. LAST=NUMPP
  197. ENDIF
  198. ENDDO
  199. * remplissage de KKSPGP
  200. * KLSPGP sert maintenant de repérage dans KKSPGP
  201. * (ouh la la quelle prise de risque !)
  202. JG=LDG
  203. SEGINI KKSPGP
  204. DO ILDG=1,LDG
  205. IPREC=KLSPGP.LECT(LAST)
  206. KKSPGP.LECT(ILDG)=LAST
  207. KLSPGP.LECT(LAST)=ILDG
  208. * KLSPGP.LECT(LAST)=0
  209. LAST=IPREC
  210. ENDDO
  211. * géométrie
  212. NBNN=LDG+1
  213. NBELEM=1
  214. NBSOUS=0
  215. NBREF=0
  216. SEGINI MEL
  217. MEL.ITYPEL=22
  218. * le premier point correspond à celui de IDDLDU
  219. NUPODU=KJSPGD.LECT(IMINCD.LNUPO(IDDLDU))
  220. *! MEL.NUM(1,1)=NUPODU
  221. *! on crée deux ! nouveaux points
  222. * on crée un nouveau point de mêmes coordonnées
  223. * support du multiplicateur de Lagrange
  224. * NBPTOT=XCOOR(/1)/(IDIM+1)
  225. * NBPTS=NBPTOT+1
  226. * SEGADJ MCOORD
  227. * DO IIDIM=1,IDIM
  228. * XCOOR((NBPTS-1)*(IDIM+1) + IIDIM)=
  229. * $ XCOOR((NUPODU-1)*(IDIM+1) + IIDIM)
  230. * ENDDO
  231. * MEL.NUM(2,1)=NBPTS
  232. NBPTOT=XCOOR(/1)/(IDIM+1)
  233. NBPTS=NBPTOT+1
  234. SEGADJ MCOORD
  235. DO IIDIM=1,IDIM
  236. XCOOR((NBPTS-1)*(IDIM+1) + IIDIM)=
  237. $ XCOOR((NUPODU-1)*(IDIM+1) + IIDIM)
  238. ENDDO
  239. MEL.NUM(1,1)=NBPTS
  240. * les points suivants correspondent à ceux de KKSPGP
  241. DO ILDG=1,LDG
  242. MEL.NUM(1+ILDG,1)=KJSPGP.LECT(KKSPGP.LECT(ILDG))
  243. ENDDO
  244. SEGDES MEL
  245. MCON.IRIGEL(1,IDDLDU)=MEL
  246. *
  247. * Création du segment descripteur pour la iddldueme matrice
  248. *
  249. NLIGRP=1+LNZ
  250. NLIGRD=1+LNZ
  251. SEGINI DESCON
  252. * Les deux premiers indices
  253. DESCON.NOELEP(1)=1
  254. DESCON.NOELED(1)=1
  255. MYMOD=LINCD.MOTS(IMINCD.LNUINC(IDDLDU))
  256. CALL FICH4(MYMOD,NOMDU,LNOMDU,
  257. $ INOMDU,
  258. $ IMPR,IRET)
  259. IF (IRET.NE.0) GOTO 9999
  260. DESCON.LISINC(1)=NOMDD(INOMDU)
  261. DESCON.LISDUA(1)=MYMOD
  262. * Les indices suivants
  263. DO JNZ=1,LNZ
  264. NUIPP=IMINCP.LNUINC(PROFM.JA(INZ+JNZ-1))
  265. MYMOP=LINCP.MOTS(NUIPP)
  266. CALL FICH4(MYMOP,NOMDD,LNOMDD,
  267. $ INOMDD,
  268. $ IMPR,IRET)
  269. IF (IRET.NE.0) GOTO 9999
  270. DESCON.LISINC(1+JNZ)=MYMOP
  271. DESCON.LISDUA(1+JNZ)=NOMDU(INOMDD)
  272. NUMPP=IMINCP.LNUPO(PROFM.JA(INZ+JNZ-1))
  273. NUMP2=KLSPGP.LECT(NUMPP)
  274. IF (NUMP2.EQ.0) THEN
  275. WRITE(IOIMP,*) 'Erreur grave no1'
  276. GOTO 9999
  277. ENDIF
  278. DESCON.NOELEP(1+JNZ)=1+NUMP2
  279. DESCON.NOELED(1+JNZ)=1+NUMP2
  280. ENDDO
  281. SEGDES DESCON
  282. MCON.IRIGEL(3,IDDLDU)=DESCON
  283. * remise à zéro de KLSPGP et suppression de KKSPGP
  284. DO ILDG=1,LDG
  285. KLSPGP.LECT(KKSPGP.LECT(ILDG))=0
  286. ENDDO
  287. SEGSUP KKSPGP
  288. *
  289. * Création de la matrice élémentaire
  290. *
  291. NELRIG=1
  292. * SEGINI ICON
  293. NLIGRP=1+LNZ
  294. NLIGRD=1+LNZ
  295. SEGINI XCON
  296. * Les deux premiers indices
  297. XCON.RE(1,1)=0.D0
  298. * Les indices suivants
  299. DO JNZ=1,LNZ
  300. VAL=VALM.A(INZ+JNZ-1)
  301. XCON.RE(1,1+JNZ,1)=VAL
  302. XCON.RE(1+JNZ,1,1)=VAL
  303. ENDDO
  304. SEGDES XCON
  305. * ICON.IMATTT(1)=XCON
  306. * SEGDES ICON
  307. * MCON.IRIGEL(4,IDDLDU)=ICON
  308. MCON.IRIGEL(4,IDDLDU)=XCON
  309. MCON.IRIGEL(5,IDDLDU)=0
  310. MCON.IRIGEL(6,IDDLDU)=0
  311. MCON.IRIGEL(7,IDDLDU)=0
  312. IF (MCHPOI.NE.0) THEN
  313. ININ=IMINCD.LNUINC(IDDLDU)
  314. INNOE=IMINCD.LNUPO(IDDLDU)
  315. MTRA2.IGEO(IDDLDU)=NBPTS
  316. MTRA2.IBIN(ININ,IDDLDU)=1
  317. MTRA2.BB(ININ,IDDLDU)=MTRAV.BB(ININ,INNOE)
  318. ENDIF
  319. ENDDO
  320. SEGSUP KLSPGP
  321. SEGDES MCON
  322. * Suppression de tous les objets de MATASS
  323. SEGSUP VALM
  324. SEGSUP PROFM
  325. SEGSUP IMINCD
  326. SEGSUP LINCD
  327. SEGSUP KJSPGD
  328. SEGSUP IMINCP
  329. SEGSUP LINCP
  330. SEGSUP KJSPGP
  331. * SEGDES MCOORD
  332. SEGACT MCOORD
  333. SEGSUP MATASS
  334. IF (MCHPOI.NE.0) THEN
  335. SEGSUP MTRAV
  336. CALL CRECHP(MTRA2,MCHPO2)
  337. SEGSUP MTRA2
  338. ELSE
  339. MCHPO2=0
  340. ENDIF
  341. *
  342. * Normal termination
  343. *
  344. IRET=0
  345. RETURN
  346. *
  347. * Format handling
  348. *
  349. *
  350. * Error handling
  351. *
  352. 9999 CONTINUE
  353. IRET=1
  354. WRITE(IOIMP,*) 'An error was detected in subroutine relr30'
  355. RETURN
  356. *
  357. * End of subroutine RELR30
  358. *
  359. END
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  
  366.  

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