Télécharger calpaq.eso

Retour à la liste

Numérotation des lignes :

  1. C CALPAQ SOURCE AM 17/03/21 21:15:01 9361
  2.  
  3. SUBROUTINE CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET)
  4.  
  5. *______________________________________________________________________
  6. *
  7. * GESTION DE LA MULTIPLICATION DES CHAMELEMS
  8. * __________________________________________
  9. *
  10. * ENTREES :
  11. * ---------
  12. *
  13. * IPCHE1 POINTEUR SUR UN 1IER MCHAML
  14. * IPCHE2 POINTEUR SUR UN 2IEM MCHAML
  15. *
  16. * Ces segments sont suposes ACTIFs en ENTREE et en SORTIE
  17. * Ils ne sont en rien modifies dans le present sous-programme.
  18. *
  19. * SORTIES :
  20. * ---------
  21. * IPCHE1 <-|
  22. * |-- POINTEURS EVENTUELLEMENT PERMUTES
  23. * IPCHE2 <-|
  24. *
  25. * K TYPE DE MULTIPLICATION 1 SCALAIRE PAR SCALAIRE
  26. * 2 COMPOSANTE PAR SCALAIRE
  27. * 3 COMPOSANTE PAR COMPOSANTE
  28. * 4 MATRICE PAR COMPOSANTE
  29. * 5 GRADIEN PAR GRADIEN
  30. *
  31. * TITC contient le TITCHE DU MCHAML A CREER
  32. * Par defaut TITC = ' '
  33. * NUMCHA LONGUEUR DU TITCHE DU CHAMP (=TITC(1:NUMCHA))
  34. * Par defaut NUMCHA = 1
  35. *
  36. * IRET = 1 SI OK
  37. * = 0 SINON AVEC GESTION ERREUR
  38. *
  39. * EBERSOLT JANVIER 87
  40. *
  41. * PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 30 10 90
  42. *_______________________________________________________________________
  43. *
  44. IMPLICIT INTEGER(I-N)
  45. IMPLICIT REAL*8(A-H,O-Z)
  46.  
  47. -INC CCOPTIO
  48. -INC SMCHAML
  49.  
  50. PARAMETER (NTIT=22)
  51.  
  52. CHARACTER*72 TIT1,TIT2,TITC
  53. CHARACTER*72 TITNOU(NTIT)
  54. *
  55. DATA TITNOU / 'NOEUD', 'GRAVITE', 'RIGIDITE', 'MASSE',
  56. 1 'STRESSES', 'DEPLACEMENTS', 'FORCES',
  57. 1 'REACTUALISATION', 'FORCES VOLUMIQUES',
  58. 1 'GRADIENT', 'CONTRAINTES', 'DEFORMATIONS',
  59. 1 'CARACTERISTIQUES', 'BIDON',
  60. 1 'TEMPERATURES', 'CONTRAINTES PRINCIPALES',
  61. 1 'MATRICE DE HOOKE', 'MATRICE DE HOOKE TANGENTE',
  62. 1 'DILATATIONS', 'VARIABLES INTERNES',
  63. 1 'GRADIENT DE FLEXION','VON MISES'/
  64. *
  65. MCHEL1 = IPCHE1
  66. MCHEL2 = IPCHE2
  67. * segact,MCHEL1,MCHEL2 <- supposes ACTIFs en E/S
  68.  
  69. * Analyse du champ 1 (IPCHE1)
  70. TIT1 = MCHEL1.TITCHE
  71. INU1 = 0
  72. INUK1 = 0
  73. C* write(ioimp,*) 'TIT1' , tit1
  74. IF (TIT1.EQ.'SCALAIRE') THEN
  75. INU1 = 1
  76. IF (MCHEL1.INFCHE(/2).GE.6) THEN
  77. INU1 = MCHEL1.INFCHE(1,6)
  78. IF (INU1.EQ.0) INU1=1
  79. ENDIF
  80. GOTO 1
  81. ENDIF
  82. *
  83. CALL PLACE(TITNOU,NTIT,INU1,TIT1)
  84. IF (INU1.EQ.0) THEN
  85. * y a t il une unique composante scalaire?
  86. nkcha = MCHEL1.ICHAML(/1)
  87. DO lkcha = 1, nkcha
  88. MCHAM1 = MCHEL1.ICHAML(lkcha)
  89. SEGACT,MCHAM1
  90. IF (MCHAM1.NOMCHE(/2).NE.1) THEN
  91. INUK1 = 2
  92. ELSE
  93. IF (MCHAM1.NOMCHE(1).NE.'SCAL') INUK1 = 2
  94. ENDIF
  95. SEGDES,MCHAM1
  96. ENDDO
  97. ENDIF
  98. 1 CONTINUE
  99. *
  100. * Analyse du champ 2 (IPCHE2)
  101. TIT2 = MCHEL2.TITCHE
  102. INU2 = 0
  103. INUK2 = 0
  104. C* write(ioimp,*) 'TIT2' , tit2
  105. IF (TIT2.EQ.'SCALAIRE') THEN
  106. INU2 = 1
  107. IF (MCHEL2.INFCHE(/2).GE.6) THEN
  108. INU2 = MCHEL2.INFCHE(1,6)
  109. IF (INU2.EQ.0) INU2 = 1
  110. ENDIF
  111. GOTO 2
  112. ENDIF
  113. *
  114. CALL PLACE(TITNOU,NTIT,INU2,TIT2)
  115. IF (INU2.EQ.0) THEN
  116. nkcha = MCHEL2.ICHAML(/1)
  117. * y a t il une unique composante scalaire?
  118. DO lkcha = 1, nkcha
  119. MCHAM2 = MCHEL2.ICHAML(lkcha)
  120. SEGACT,MCHAM2
  121. IF (MCHAM2.NOMCHE(/2).NE.1) THEN
  122. INUK2 = 2
  123. ELSE
  124. IF (MCHAM2.NOMCHE(1).NE.'SCAL') INUK2 = 2
  125. ENDIF
  126. SEGDES,MCHAM2
  127. ENDDO
  128. ENDIF
  129. 2 CONTINUE
  130.  
  131. * write(ioimp,*) ' inu1,inuk1, inu2,inuk2',inu1,inuk1,inu2,inuk2
  132. *
  133. * S. PASCAL
  134. * Traitement particulier dans le cas d'un produit de 2 MCHAMLs
  135. * a plusieurs composantes dont certaines sont de type EVOLUTIOn.
  136. * Je cherche dans le MCHEL1 les composantes de type EVOL.
  137. * Si aucune EVOL, INUJ1=0
  138. * Si toute EVOL, INUJ1>0
  139. * Sinon, INUJ1<0
  140. * Idem pour MCHEL2 avec INUJ2
  141. * Je me place dans le cas d'un produit composante par composante :
  142. INUJ1 = 0
  143. INUJ2 = 0
  144. IF (INU1.EQ.INU2 .AND. INU1.GT.5) THEN
  145. nkcha = MCHEL1.ICHAML(/1)
  146. NJ1 = 0
  147. DO lkcha =1, nkcha
  148. MCHAM1 = MCHEL1.ICHAML(lkcha)
  149. SEGACT,MCHAM1
  150. NJ = MCHAM1.IELVAL(/1)
  151. DO JELV = 1, NJ
  152. IF (MCHAM1.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
  153. INUJ1 = INUJ1 + 1
  154. ENDIF
  155. ENDDO
  156. NJ1 = NJ1 + NJ
  157. ENDDO
  158. * IF (INUJ1.GT.0) THEN
  159. IF (INUJ1.NE.NJ1) INUJ1 = 0 - INUJ1
  160. * ENDIF
  161. nkcha = MCHEL2.ICHAML(/1)
  162. NJ2 = 0
  163. DO lkcha =1, nkcha
  164. MCHAM2 = MCHEL2.ICHAML(lkcha)
  165. SEGACT,MCHAM2
  166. NJ = MCHAM2.IELVAL(/1)
  167. DO JELV = 1, NJ
  168. IF (MCHAM2.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
  169. INUJ2 = INUJ2 + 1
  170. ENDIF
  171. ENDDO
  172. NJ2 = NJ2 + NJ
  173. ENDDO
  174. * IF (INUJ2.GT.0) THEN
  175. IF (INUJ2.NE.NJ2) INUJ2 = 0 - INUJ2
  176. * ENDIF
  177. ENDIF
  178. c* write(ioimp,*) ' inuj1,inuj2 ',inuj1,inuj2
  179. *
  180. IRET = 1
  181. *
  182. IF (INU1.EQ.0.AND.INUK1.EQ.0) THEN
  183. NUMCHA=1
  184. TITC = ' '
  185. *
  186. * AM 20/03/17
  187. *
  188. IF(INU2.EQ.0.AND.INUK2.EQ.0) THEN
  189. K=1
  190. ELSE
  191. K=2
  192. iii = IPCHE2
  193. IPCHE2 = IPCHE1
  194. IPCHE1 = iii
  195. ENDIF
  196. ELSE IF(INU2.EQ.0.AND.INUK2.EQ.0) THEN
  197. NUMCHA=1
  198. TITC=' '
  199. K=2
  200. ELSE IF(INU1.EQ.0.OR.INU2.EQ.0) THEN
  201. NUMCHA=1
  202. TITC=' '
  203. K=3
  204. ELSE IF(INU1.EQ.INU2.AND.INU1.LE.5.AND.INU1.GE.1) THEN
  205. NUMCHA=1
  206. TITC=' '
  207. K=1
  208. ELSE IF(INU1.EQ.10.AND.INU2.EQ.10) THEN
  209. NUMCHA=8
  210. TITC='GRADIENT'
  211. K=5
  212. ELSE IF(INU1.EQ.10.AND.INU2.EQ.21) THEN
  213. NUMCHA=8
  214. TITC='GRADIENT'
  215. K=5
  216. ELSE IF(INU1.EQ.21.AND.INU2.EQ.10) THEN
  217. NUMCHA = 19
  218. TITC = 'GRADIENT DE FLEXION'
  219. K=5
  220. ELSE IF(INU1.EQ.21.AND.INU2.EQ.21) THEN
  221. NUMCHA=19
  222. TITC='GRADIENT DE FLEXION'
  223. K=5
  224. ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5) THEN
  225. NUMCHA=1
  226. TITC=' '
  227. K=3
  228. IF ( (INUJ1.EQ.0.AND.INUJ2.NE.0) .OR.
  229. & (INUJ1.LT.0.AND.INUJ2.GT.0) ) THEN
  230. iii = IPCHE1
  231. IPCHE1 = IPCHE2
  232. IPCHE2 = iii
  233. ENDIF
  234. ELSE IF (INU1.EQ.1.AND.(INU2.EQ.6.OR.INU2.EQ.7)) THEN
  235. NUMCHA=1
  236. TITC=' '
  237. K=2
  238. iii = IPCHE1
  239. IPCHE1 = IPCHE2
  240. IPCHE2 = iii
  241. ELSE IF (INU2.EQ.1.AND.(INU1.EQ.6.OR.INU1.EQ.7)) THEN
  242. NUMCHA=1
  243. TITC=' '
  244. K=2
  245. ELSE IF (INU1.EQ.3.AND.
  246. & (INU2.EQ.13.OR.INU2.EQ.14.OR.INU2.EQ.17)) THEN
  247. NUMCHA=1
  248. TITC=' '
  249. K=2
  250. iii = IPCHE1
  251. IPCHE1 = IPCHE2
  252. IPCHE2 = iii
  253. ELSE IF (INU2.EQ.3.AND.
  254. & (INU1.EQ.13.OR.INU1.EQ.14.OR.INU1.EQ.17)) THEN
  255. NUMCHA=1
  256. TITC=' '
  257. K=2
  258. ELSE IF (INU1.EQ.5.AND.(INU2.EQ.11.OR.INU2.EQ.12.OR.
  259. & INU2.EQ.15.OR.INU2.EQ.16.OR.INU2.EQ.18)) THEN
  260. NUMCHA=1
  261. TITC=' '
  262. K=2
  263. iii = IPCHE1
  264. IPCHE1 = IPCHE2
  265. IPCHE2 = iii
  266. ELSE IF (INU2.EQ.5.AND.(INU1.EQ.11.OR.INU1.EQ.12.OR.
  267. & INU1.EQ.15.OR.INU1.EQ.16.OR.INU1.EQ.18)) THEN
  268. NUMCHA=1
  269. TITC=' '
  270. K=2
  271. ELSE IF (INU1.EQ.11.AND.(INU2.EQ.17.OR.INU2.EQ.18)) THEN
  272. NUMCHA=12
  273. TITC='DEFORMATIONS'
  274. K=4
  275. ELSE IF (INU1.EQ.12.AND.(INU2.EQ.17.OR.INU2.EQ.18)) THEN
  276. NUMCHA=11
  277. TITC='CONTRAINTES'
  278. K=4
  279. ELSE IF (INU2.EQ.11.AND.(INU1.EQ.17.OR.INU1.EQ.18)) THEN
  280. NUMCHA=12
  281. TITC='DEFORMATIONS'
  282. K=4
  283. iii = IPCHE1
  284. IPCHE1 = IPCHE2
  285. IPCHE2 = iii
  286. ELSE IF (INU2.EQ.12.AND.(INU1.EQ.17.OR.INU1.EQ.18)) THEN
  287. NUMCHA=11
  288. TITC='CONTRAINTES'
  289. K=4
  290. iii = IPCHE1
  291. IPCHE1 = IPCHE2
  292. IPCHE2 = iii
  293. ELSE
  294. IRET = 0
  295. NUMCHA=1
  296. TITC=' '
  297. K = 0
  298. ENDIF
  299. *
  300. * ERREUR LES CHAMELEM QUE L ON TENTE DE MULTIPLIER
  301. * OU DIVISER SONT INCOMPATIBLES
  302. *
  303. IF (IRET.EQ.0) THEN
  304. MOTERR( 1:16) = TIT1(1:16)
  305. MOTERR(17:32) = TIT2(1:16)
  306. CALL ERREUR(993)
  307. ENDIF
  308. *
  309. * SEGDES MCHEL1,MCHEL2 <- on les laisse ACTIFs comme en entree
  310. *
  311. RETURN
  312. END
  313.  
  314.  
  315.  
  316.  

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