Télécharger calpaq.eso

Retour à la liste

Numérotation des lignes :

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

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