Télécharger depimp.eso

Retour à la liste

Numérotation des lignes :

  1. C DEPIMP SOURCE FD218221 16/07/04 21:15:03 8995
  2. SUBROUTINE DEPIMP
  3.  
  4. IMPLICIT INTEGER(I-N)
  5. CHARACTER*4 charm,charre
  6. REAL*8 XXA,vval,X0,X1
  7. LOGICAL ISCALA
  8. C
  9. C **** CE SUBROUTINE SERT A IMPOSER DES VALEURS DE DEPLACEMENTS
  10. C **** IMPOSES NON NULS.
  11. C
  12. C SYNTAXE TOTO = DEPIMPOSE BRIG FLOT
  13. C
  14. C OU TOTO = DEPIMPOSE BRIG CHPSCAL
  15. C TOTO = DEPIMPOSE BRIG CHPOI ( COMPOSANTES PRIMALES)
  16. C
  17. C EN ENTREE : BRIG OBJET RIGIDITE DE TYPE BLOQUAGE
  18. C FLOT LA VALEUR DU DEPLACEMENT A IMPOSER
  19. C CHPSCAL EST UN CHPOINT DE SCALAIRE QUI PRECISE LA
  20. C VALEUR A IMPOSER EN CHAQUE POINT.
  21. C
  22. C EN SORTIE UN OBJET DE TYPE CHPOINT
  23. C
  24. -INC SMRIGID
  25. -INC SMCHPOI
  26. -INC CCOPTIO
  27. -INC SMELEME
  28. -INC SMCOORD
  29. -INC SMTABLE
  30.  
  31. SEGMENT SCOLOR
  32. CHARACTER*4 COLOR(NBELEM)
  33. ENDSEGMENT
  34. POINTEUR SCOL1.SCOLOR,SCOL2.SCOLOR,SCOL3.SCOLOR
  35. SEGMENT ICPR(NNN)
  36. segment irelat
  37. logical lrelat(nnn)
  38. end segment
  39. logical lllblo,lllrel
  40.  
  41. C Initialisations
  42. ISCALA=.TRUE.
  43.  
  44. c lecture table liaisons statiques
  45. CALL LIRTAB('LIAISONS_STATIQUES',ipt,0,iretou)
  46. if (iretou.ne.0) goto 1100
  47. C
  48. C **** LECTURE D'UN OBJET DE TYPE RIGIDITE
  49. C
  50. CALL LIROBJ('RIGIDITE',IPOIRI,1,IRETOU)
  51. IF(IERR.NE.0) RETURN
  52. C
  53. C LECTURE D'UNE VALEUR SI ECHEC LECTURE D'UN CHPOINT DE SCALAIRES
  54. C OU DE COMPOSANTES PRIMALES DES BLOQUAGES
  55. C
  56. CALL LIRREE(XXA,0,IREVAL)
  57. VVAL=XXA
  58. IF(IREVAL.EQ.0) THEN
  59. CALL LIROBJ('CHPOINT ',ISCA,1,IRETOU)
  60. IF(IERR.NE.0) RETURN
  61. MCHPO1=ISCA
  62. SEGACT MCHPO1
  63. C Si le CHPOINT n'a aucune sous-zone, il est vide, alors erreur
  64. NBSZCH=MCHPO1.IPCHP(/1)
  65. IF(NBSZCH.LT.1) THEN
  66. SEGDES,MCHPO1
  67. MOTERR(1:8)='CHPOINT '
  68. INTERR(1)=ISCA
  69. CALL ERREUR(356)
  70. RETURN
  71. ENDIF
  72. msoup1 = MCHPO1.ipchp(1)
  73. segact msoup1
  74. nbcomp = msoup1.noharm(/1)
  75. c ... ISCALA = .TRUE. correspond au traitement d'un CHPOINT
  76. c contenant une seule zone dans laquelle il y a une seule
  77. c composante et dont le nom peut être quelconque. Pour
  78. c l'instant on s'en sert pour vérifier si le CHPOINT est bel
  79. c et bien SCALAIRE ...
  80. if(nbszch.eq.1.AND.nbcomp.eq.1) then
  81. iscala = .TRUE.
  82. else
  83. ISCALA = .FALSE.
  84. endif
  85. ENDIF
  86. c
  87. c ... test si la RIGIDITE n'est pas vide, si OUI on créé un CHPOINT
  88. c vide puis on s'en va ...
  89. c
  90. MRIGID=IPOIRI
  91. SEGACT,MRIGID
  92. NNN=IRIGEL(/2)
  93. IF (NNN.EQ.0) THEN
  94. NSOUPO=0
  95. NAT=1
  96. SEGINI MCHPOI
  97. MTYPOI='FLX'
  98. JATTRI(1) = 2
  99. MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'//
  100. # ' DEPIMP'
  101. IFOPOI = IFOUR
  102. SEGDES MCHPOI
  103. GO TO 252
  104. ENDIF
  105.  
  106. IPT2=0
  107. NOHA=0
  108. C
  109. C BOUCLE SUR LES SOUS RIGIDITES . ON VERIFIE QUE LAMBDA EXISTE ET ON
  110. C CONSTRUIT LE SEGMENT GEOMETRIE LX1 LX2 NNOE, DANS scol1.COLOR ON MET LE
  111. C NOM DE L'INCONNUE
  112. C
  113. segini,irelat
  114. DO 1 NN=1,NNN
  115. DESCR=IRIGEL(3,NN)
  116. MELEME=IRIGEL(1,NN)
  117. NOHAR=IRIGEL(5,NN)
  118. IF(NOHA.NE.0.AND.NOHA.NE.NOHAR) THEN
  119. CALL ERREUR ( 25 )
  120. RETURN
  121. ENDIF
  122. lrelat(nn) = .false.
  123. c ... on va chercher les multiplicateurs dans DESCR ...
  124. SEGACT,DESCR
  125. IA=LISINC(/2)
  126. DO 2 I=1,IA
  127. IF(LISINC(I).EQ.'LX ') GO TO 3
  128. 2 CONTINUE
  129. c ... on n'a pas trouvé de multiplicateurs, donc bye ...
  130. SEGDES,DESCR
  131. CALL ERREUR(245)
  132. RETURN
  133. c ... on a trouvé les multiplicateurs ...
  134. 3 CONTINUE
  135. SEGACT,MELEME
  136. NBNN=2
  137. NBELEM=NUM(/2)
  138. NBREF=0
  139. NBSOUS=0
  140. SEGINI,IPT1,SCOL1
  141. c ... boucle sur les éléments de blocage ...
  142. DO 4 J=1,NUM(/2)
  143. JB=0
  144. c ... JA sert à compter les multiplicateurs dans chaque
  145. c élément, normalement il y en a 2 ...
  146. JA=0
  147. c ... boucle sur les noeuds de ces éléments ...
  148. DO 4 K=1,NUM(/1)
  149. c ... si c'est un support de multiplicateur, on met son n°
  150. c dans IPT1 (position 1 ) ...
  151. IF(LISINC(K).EQ.'LX ') THEN
  152. JA=JA+1
  153. IPT1.NUM(JA,J)=NUM(NOELEP(K),J)
  154. c ... sinon ...
  155. ELSE
  156. c ... on teste si c'est le premier DDL <<physique>>, si OUI ...
  157. IF(JB.EQ.0) THEN
  158. c ... on met son n° dans IPT1 (position 2) ...
  159. JB=2
  160. IPT1.NUM(JB,J)=NUM(NOELEP(K),J)
  161. C ... et le nom du DDL dans SCOL1.COLOR ...
  162. SCOL1.COLOR(J)=LISINC(K)
  163. c ... sinon (c.à d. ceci est une relation et non un blocage) ...
  164. ELSE
  165. c ... on teste si le support n'est pas le même que
  166. c celui du premier DDL <<physique>> ...
  167. IF(IPT1.NUM(JB,J).NE.NUM(NOELEP(K),J)) THEN
  168. c ... si c'est le cas on sert une ERREUR en cas de lecture d'un CHPOINT ...
  169. IF(IREVAL.ne.1) then
  170. CALL ERREUR(794)
  171. RETURN
  172. endif
  173. ENDIF
  174. c ... et de toute façon on efface le nom du DDL de SCOL1.COLOR ...
  175. SCOL1.COLOR(J)=' '
  176. lrelat(nn) = .true.
  177. ENDIF
  178. ENDIF
  179. 4 CONTINUE
  180.  
  181. C
  182. C SI NN= 1 IPT2 = IPT1; SINON IPT3 = IPT2 + IPT1, PUIS IPT2 = IPT3
  183. C
  184. SEGDES,DESCR
  185. IF(IPT2.NE.0) GO TO 5
  186. IPT2=IPT1
  187. SCOL2=SCOL1
  188. SEGDES,MELEME
  189. GO TO 1
  190. 5 CONTINUE
  191. NA=IPT1.NUM(/2)
  192. NB=IPT2.NUM(/2)
  193. NBELEM=NA+NB
  194. SEGINI,IPT3,SCOL3
  195. DO 71 I=1,NA
  196. SCOL3.COLOR(I)=SCOL1.COLOR(I)
  197. DO 72 J=1,2
  198. IPT3.NUM(J,I)=IPT1.NUM(J,I)
  199. 72 CONTINUE
  200. 71 CONTINUE
  201. DO 8 I=1,NB
  202. SCOL3.COLOR(I+NA)=SCOL2.COLOR(I)
  203. DO 9 J=1,2
  204. IPT3.NUM(J,I+NA)=IPT2.NUM(J,I)
  205. 9 CONTINUE
  206. 8 CONTINUE
  207. SEGSUP IPT1,SCOL1
  208. SEGSUP,IPT2,SCOL2
  209. IPT2=IPT3
  210. SCOL2=SCOL3
  211. SEGDES,MELEME
  212. 1 CONTINUE
  213. SEGDES,MRIGID
  214. c
  215. c ... on va vérifier si la matrice contient seulement les blocages, ou seulement
  216. c les relations (on en a seulement besoin en cas de lecture d'un CHPOINT) ...
  217. c
  218. if(ireval.eq.0) then
  219. lllblo = .true.
  220. lllrel = .true.
  221. do 77 i=1,nnn
  222. lllblo = lllblo .and. (.not.lrelat(i))
  223. lllrel = lllrel .and. lrelat(i)
  224. 77 continue
  225. segsup,irelat
  226. c ... si les deux sont faux, on a un mélange de blocages et de relations ...
  227. if(.not.lllblo .and. .not.lllrel) then
  228. call erreur(795)
  229. return
  230. endif
  231. c ... si on n'a que des relations, le CHPOINT doit être scalaire ...
  232. if(lllrel .and. .not.iscala) then
  233. call erreur(796)
  234. return
  235. endif
  236. else
  237. segsup,irelat
  238. endif
  239. C
  240. C ON VIENT DE CREER IPT2 CONTENANT DES ELEMENTS COMPOSES DE LX1 NOE
  241. C DANS COLOR ON A LE NOM DE L'INCONNUE A METTRE EN FACE DE NNOE
  242. C
  243. NSOUPO=1
  244. NAT=1
  245. SEGINI,MCHPOI
  246. MTYPOI='FLX'
  247. JATTRI(1) = 2
  248. MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'//
  249. # ' DEPIMP'
  250. IFOPOI=IFOUR
  251.  
  252. NC=1
  253. SEGINI,MSOUPO
  254. IPCHP(1)=MSOUPO
  255. SEGDES,MCHPOI
  256. NOCOMP(1)='FLX'
  257. NOHARM(1)=NOHAR
  258. write (charm,fmt='(A4)') nohar
  259. if (charm.eq.'NOHA') noharm(1)=nifour
  260. C
  261. C CREATION DE L'ELEMENT SUPPORT GEOMETRIQUE ET EN MEME TEMPS DES
  262. C VALEURS VPOCHA
  263. C
  264. NBNN=1
  265. NBELEM=IPT2.NUM(/2)
  266. SEGINI MELEME
  267. IGEOC=MELEME
  268. ITYPEL=1
  269.  
  270. N=IPT2.NUM(/2)
  271. SEGINI,MPOVAL
  272. IPOVAL=MPOVAL
  273. SEGDES,MSOUPO
  274.  
  275. c ... Si on a lu un réél, il n'y a pas grand chose à faire ...
  276. IF(IREVAL.NE.0) GO TO 250
  277. C
  278. C CAS DU CHPOINT SCALAIRE, on peut mettre un teste qui porte seulement
  279. C sur ISCALA car on a déjà vérifié que cela va ensemble avec LLLREL
  280. C
  281. IF(ISCALA) THEN
  282. MSOUP1=MCHPO1.IPCHP(1)
  283. SEGACT MSOUP1
  284. MPOVA1=MSOUP1.IPOVAL
  285. SEGACT MPOVA1
  286. NNN=XCOOR(/1)/(IDIM+1)
  287. SEGINI ICPR
  288. IPT3=MSOUP1.IGEOC
  289. SEGACT IPT3
  290. NNU=IPT3.NUM(/2)
  291. DO 25 IUY=1,NNU
  292. ICPR(IPT3.NUM(1,IUY))=IUY
  293. 25 CONTINUE
  294. DO 26 IU=1,IPT2.NUM(/2)
  295. JA=IU
  296. NUM(1,JA)=IPT2.NUM(1,IU)
  297. ID=ICPR(IPT2.NUM(2,IU))
  298. IF( ID.EQ.0) THEN
  299. CALL ERREUR(244)
  300. RETURN
  301. ELSE
  302. XXA=MPOVA1.VPOCHA(ID,1)
  303. VPOCHA(JA,1)=XXA
  304. ENDIF
  305. 26 CONTINUE
  306. SEGDES MPOVA1,MSOUP1,MCHPO1
  307. SEGDES IPT3
  308. SEGSUP ICPR
  309. ELSE
  310. C
  311. C CAS DU CHPOINT D'INCONNUES PRIMALES
  312. C
  313. NNN=XCOOR(/1)/(IDIM+1)
  314. SEGINI ICPR
  315. JB=1
  316. DO 36 J=1,IPT2.NUM(/2)
  317. NUM(1,JB)=IPT2.NUM(1,J)
  318. JB=JB+1
  319. 36 CONTINUE
  320. DO 31 I=1,MCHPO1.IPCHP(/1)
  321. DO 40 J=1,NNN
  322. ICPR(J)=0
  323. 40 CONTINUE
  324. MSOUP1=MCHPO1.IPCHP(I)
  325. SEGACT MSOUP1
  326. MPOVA1=MSOUP1.IPOVAL
  327. SEGACT MPOVA1
  328. IPT1=MSOUP1.IGEOC
  329. SEGACT IPT1
  330. IA=0
  331. DO 32 J=1,IPT1.NUM(/2)
  332. ID=IPT1.NUM(1,J)
  333. IF(ICPR(ID).EQ.0) THEN
  334. IA=IA+1
  335. ICPR(ID)=IA
  336. ELSE
  337. CALL ERREUR(245)
  338. RETURN
  339. ENDIF
  340. 32 CONTINUE
  341. DO 33 J=1,IPT2.NUM(/2)
  342. ID=IPT2.NUM(2,J)
  343. JB=JB+2
  344. IF(ICPR(ID).EQ.0) GO TO 33
  345. DO 34 K=1,MSOUP1.NOCOMP(/2)
  346. IF(MSOUP1.NOCOMP(K).EQ.SCOL2.COLOR(J)) GO TO 35
  347. 34 CONTINUE
  348. GO TO 33
  349. 35 CONTINUE
  350. JD=ICPR(ID)
  351. XXA=MPOVA1.VPOCHA(JD,K)
  352. JA=J
  353. VPOCHA(JA,1)=XXA
  354. 33 CONTINUE
  355. SEGDES MSOUP1,MPOVA1,IPT1
  356. 31 CONTINUE
  357. SEGSUP ICPR
  358. ENDIF
  359. GO TO 251
  360.  
  361. C ... En cas de lecture d'un réél le remplissage du segment MPOVAL est assez simple ...
  362. 250 CONTINUE
  363. DO 10 I=1,N
  364. VPOCHA(I,1)=VVAL
  365. 10 CONTINUE
  366. c ... celui du segment MELEME n'est pas plus compliqué ...
  367. DO 11 I=1,IPT2.NUM(/2)
  368. JA=I
  369. NUM(1,JA)=IPT2.NUM(1,I)
  370. 11 CONTINUE
  371.  
  372. 251 CONTINUE
  373. SEGSUP IPT2,SCOL2
  374. SEGDES,MPOVAL,MELEME
  375. 252 CONTINUE
  376. CALL ECROBJ('CHPOINT ',MCHPOI)
  377. RETURN
  378.  
  379. 1100 CONTINUE
  380. call depim2(ipt)
  381. return
  382.  
  383. END
  384.  
  385.  
  386.  
  387.  
  388.  
  389.  
  390.  
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  

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