Télécharger depimp.eso

Retour à la liste

Numérotation des lignes :

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

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