Télécharger depimp.eso

Retour à la liste

Numérotation des lignes :

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

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