Télécharger vecte.eso

Retour à la liste

Numérotation des lignes :

vecte
  1. C VECTE SOURCE PV 22/04/21 08:32:54 11344
  2. C
  3. C-------------------------------------------------------------------------
  4. C
  5. C Opérateur VECTEUR
  6. C -----------------
  7. C
  8. C VEC1 = VECT | CHPO1 (FLOT1) (| 'DEPL' | 'FORC' |) (COUL1) ;
  9. C | (| LMOT1 |)
  10. C | (| MOT1 MOT2 (MOT3 si 3D) |)
  11. C |
  12. C | CHAM1 (CHAM2) MOD1 (FLOT1) (MOCOMP1) (LISMO1) ;
  13. c |
  14. c | CHAM1 MOD1 (FLOT1) LCOMP1 (LISMO1);
  15. C
  16. C Objet :
  17. C _______
  18. C
  19. C L'opérateur VECT construit un objet de type VECTEUR à partir :
  20. C - des composantes d'un champ de vecteurs,
  21. C - d'un champ par éléments de contraintes principales,
  22. C - d'un champ par éléments de variables internes.
  23. C
  24. C-------------------------------------------------------------------------
  25. C
  26. C VERIFICATION DE L'EXISTENCE D UN VECTEUR
  27. C VERSION OU ON NE LIT PAS DE MELEME
  28. C
  29. C-------------------------------------------------------------------------
  30. C
  31. C PM, 20/03/2007 : prise en compte de la couleur COUL1
  32. C BP, 04/05/2012 : ajout syntaxe 3 (appel a vecte4)
  33. C
  34. C-------------------------------------------------------------------------
  35. SUBROUTINE VECTE
  36.  
  37. IMPLICIT INTEGER(I-N)
  38. IMPLICIT REAL*8 (A-H,O-Z)
  39.  
  40.  
  41. -INC PPARAM
  42. -INC CCOPTIO
  43. -INC CCGEOME
  44. -INC SMCHPOI
  45. -INC SMVECTE
  46. -INC SMELEME
  47. -INC SMCHAML
  48. -INC CCREEL
  49. -INC SMCOORD
  50. -INC SMLMOTS
  51.  
  52. CHARACTER*(LOCOMP) NV(3),NOC,CMOT
  53. REAL*8 AMP,xmin,xmax,ymin,ymax,zmin,zmax,vmin,vmax
  54. LOGICAL LSUPR
  55.  
  56. CHARACTER*4 MOTVEC(2)
  57. DATA MOTVEC/ 'DEPL','FORC'/
  58.  
  59. CHARACTER*(LOCOMP) NU(3)
  60. DATA NU/'UX ','UY ','UZ '/
  61.  
  62. segact mcoord
  63. MELEME=0
  64.  
  65. CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)
  66. IF(IRETOU .EQ. 1) CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  67. IF(IERR.NE.0) RETURN
  68.  
  69. *
  70. * Cas du CHAMELEM
  71. * --------------
  72. *
  73. IF (IRETOU.EQ.0) THEN
  74. * Lecture d'un CHAMELEM obligatoirement
  75. * de CONTRAINTES PRINCIPALES ou de VARIABLES INTERNES
  76. CALL LIROBJ('MCHAML ',MCHA1,1,IRET)
  77. CALL ACTOBJ('MCHAML ',MCHA1,1)
  78. IF (IERR.NE.0) RETURN
  79.  
  80. MCHELM = MCHA1
  81. ICAS = 0
  82. IF (TITCHE.EQ.'CONTRAINTES PRINCIPALES') ICAS = 1
  83. IF (TITCHE.EQ.'VARINTER' .OR.
  84. & TITCHE.EQ.'VARIABLES INTERNES') ICAS = 2
  85. c write(*,*) 'ICAS=',ICAS
  86. IF (ICAS.EQ.0) THEN
  87. c Lecture obligatoire des composantes a afficher
  88. LMOT0 = 0
  89. CALL LIROBJ('LISTMOTS',LMOT0,1,IRET)
  90. if (IRET.ne.0) then
  91. ICAS = 3
  92. else
  93. write(IOIMP,*)'LES COMPOSANTES SONT OBLIGATOIRES POUR LES',
  94. & 'CHAMPS DE TYPE AUTRES QUE CONTRAINTES PRINCIPALES',
  95. & 'ou VARIABLES INTERNES'
  96. * L'objet de type %m1:8 n'a pas le bon sous-type
  97. MOTERR(1:8) = 'CHAMELEM'
  98. CALL ERREUR(302)
  99. RETURN
  100. endif
  101. ENDIF
  102.  
  103. * Lecture éventuelle d'un CHAMELEM de caractéristiques
  104. MCHA2 = 0
  105. CALL LIROBJ('MCHAML ',MCHA2,0,IRET)
  106. c write(*,*) '2eme mchaml =',MCHA2
  107. IF (IERR.NE.0) RETURN
  108. IF (IRET.EQ.1) THEN
  109. CALL ACTOBJ('MCHAML ',MCHA2,1)
  110. MCHELM = MCHA2
  111. c write(*,*) '2eme mchaml TITCHE=',TITCHE
  112. IF (TITCHE.NE.'CARACTERISTIQUES') THEN
  113. * Il manque un champ par élément de sous-type %m1:16
  114. c write(*,*) 'erreur dans vecte'
  115. MOTERR(1:16) = 'CARACTERISTIQUES'
  116. CALL ERREUR(565)
  117. RETURN
  118. ENDIF
  119. ENDIF
  120.  
  121. cbp 3 CONTINUE
  122. * Lecture du modèle
  123. CALL LIROBJ('MMODEL ',MOD1,1,IRET)
  124. CALL ACTOBJ('MMODEL ',MOD1,1)
  125. IF (IERR.NE.0) RETURN
  126. IPIN=MCHA1
  127. CALL REDUAF(IPIN,MOD1,MCHA1,0,IR,KER)
  128. IF(IR .NE. 1) CALL ERREUR(KER)
  129. IF(IERR .NE. 0) RETURN
  130. cbp MCHA2=0
  131. IF (MCHA2 .NE. 0) THEN
  132. IPIN=MCHA2
  133. CALL REDUAF(IPIN,MOD1,MCHA2,0,IR,KER)
  134. IF(IR .NE. 1) CALL ERREUR(KER)
  135. IF(IERR .NE. 0) RETURN
  136. ENDIF
  137.  
  138. * Lecture du coefficient d'amplification optionnel
  139. AMP=1.D0
  140. CALL LIRREE(AMP,0,IRETOU)
  141.  
  142. * Lecture éventuelle de la composante à conserver
  143. IF (ICAS.EQ.1) THEN
  144. CMOT = ' '
  145. CALL LIRCHA(CMOT,0,IRETOU)
  146. ENDIF
  147.  
  148. * Lecture de la liste des couleurs à employer pour chaque composante
  149. LMOT1 = 0
  150. CALL LIROBJ('LISTMOTS',LMOT1,0,IRET)
  151. IF (IERR.NE.0) RETURN
  152.  
  153. * Création des vecteurs suivant les cas
  154. IF (ICAS.EQ.1)
  155. & CALL VECTE2(MCHA1,MCHA2,MOD1,AMP,CMOT,LMOT1,MVECTE)
  156. IF (ICAS.EQ.2)
  157. & CALL VECTE3(MCHA1,MCHA2,MOD1,AMP,LMOT1,MVECTE)
  158. IF (ICAS.EQ.3)
  159. & CALL VECTE4(MCHA1,MCHA2,MOD1,AMP,LMOT0,LMOT1,MVECTE)
  160. IF (IERR.NE.0) RETURN
  161.  
  162. CALL ECROBJ ('VECTEUR ',MVECTE)
  163. RETURN
  164. ENDIF
  165. *
  166. * Cas du CHPOINT
  167. * --------------
  168. *
  169. *-- Détermination de MLMOT1, listmots des composantes à prendre en compte
  170. * On essaie de lire les mot clés 'DEPL' 'FORC'
  171. CALL LIRMOT(MOTVEC,2,IMOT,0)
  172. IF (IMOT.NE.0) THEN
  173. CALL IDCOMP(MOTVEC(IMOT),MLMOT1)
  174. IF (IERR.NE.0) RETURN
  175. IRETOU=1
  176. LSUPR=.TRUE.
  177. ELSE
  178. * sinon on cherche un listmots de composantes
  179. CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
  180. LSUPR=.FALSE.
  181. ENDIF
  182.  
  183. IF (IRETOU.NE.0) THEN
  184. SEGACT MLMOT1
  185.  
  186. * Vérification du nombre de composantes
  187. NM=MLMOT1.MOTS(/2)
  188. IF (NM.LT.IDIM) THEN
  189. * routine %m1:8 : On voulait un %m9:16 à %i1 composantes au lieu de %i2 .
  190. MOTERR(1:8)='VECTE '
  191. MOTERR(9:16)='LISTMOTS'
  192. INTERR(1)=IDIM
  193. INTERR(2)=NM
  194. CALL ERREUR(699)
  195. RETURN
  196. ENDIF
  197.  
  198. * Stockage dans la table NV
  199. DO K=1,IDIM
  200. NV(K)=MLMOT1.MOTS(K)
  201. ENDDO
  202.  
  203. IF (LSUPR) THEN
  204. SEGSUP MLMOT1
  205. ELSE
  206. SEGDES MLMOT1
  207. ENDIF
  208. ELSE
  209. * Si pas de listmots (implicite ou explicite),
  210. * on lit autant de mots que la dimension
  211. KOK=0
  212. DO 9 K=1,IDIM
  213. CALL LIRCHA(CMOT,0,IRETOU)
  214. IF (IRETOU.NE.0) THEN
  215. KOK=K
  216. NV(K)=CMOT
  217. ENDIF
  218. 9 CONTINUE
  219.  
  220. IF (KOK.GT.0 .AND. KOK.LT.IDIM) THEN
  221. * Si le nombre de composantes est insuffisant, c'est qu'elles
  222. * n'étaient en fait pas données. On réécrit les mots lus
  223. * abusivement pour usage ultérieur
  224. DO K=1,KOK
  225. CMOT=NV(K)
  226. CALL ECRCHA(CMOT)
  227. ENDDO
  228. ENDIF
  229. ENDIF
  230.  
  231. * Et enfin, si aucune spécification, on prend les composantes par
  232. * défaut dans la table NU.
  233. IF (IRETOU.EQ.0) THEN
  234. DO 8 L=1,IDIM
  235. NV(L)=NU(L)
  236. 8 CONTINUE
  237. ENDIF
  238. IF (IERR.NE.0) RETURN
  239.  
  240. *-- Lecture de la couleur (valeur par défaut sinon)
  241. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  242. IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  243. ICOUL=ICOUL-1
  244.  
  245. C VERIFICATION QU'IL Y A NV(K) PARMI LES INCONNUES DU CHPOINT
  246. C SEGACT MCHPOI
  247. C NSOUPO=IPCHP(/1)
  248. C IRAT=1
  249. C IF (NSOUPO.EQ.0) GOTO 13
  250. C DO 10 ISOUPO=1,NSOUPO
  251. C MSOUPO=IPCHP(ISOUPO)
  252. C SEGACT MSOUPO
  253. C NCV=NOCOMP(/2)
  254. C DO 11 I=1,NCV
  255. C NOC=NOCOMP(I)
  256. C DO 12 J=1,IDIM
  257. C IF (NOC.EQ.NV(J)) IRAT=0
  258. C 12 CONTINUE
  259. C 11 CONTINUE
  260. C SEGDES MSOUPO
  261. C 10 CONTINUE
  262. C MOTERR(1:4)=NV(1)
  263. C MOTERR(5:12)=MTYPOI
  264. C SEGDES MCHPOI
  265. C IF (IRAT.EQ.1) THEN
  266. C* La composante %m1:4 n'existe pas pour le champ %m5:8
  267. C CALL ERREUR(77)
  268. C ENDIF
  269. C 13 CONTINUE
  270. AMP=-xsgran
  271. CALL LIRREE(AMP,0,IRETOU)
  272. NVEC=1
  273. ID=IDIM
  274. SEGINI MVECTE
  275. IGEOV(NVEC)=MELEME
  276. ICHPO(NVEC)=MCHPOI
  277. AMPF(NVEC)=AMP
  278. NOCOUL(NVEC)=ICOUL
  279. DO 14 ID=1,IDIM
  280. NOCOVE(NVEC,ID)=NV(ID)
  281. 14 CONTINUE
  282. * Amplification automatique on calcul le coeff
  283. if (iretou.eq.0) then
  284. idimp1 = idim+1
  285. xmin=xsgran
  286. ymin=xsgran
  287. zmin=xsgran
  288. vmax=-xsgran
  289. xmax=-xsgran
  290. ymax=-xsgran
  291. zmax=-xsgran
  292. do 50 i=1,ipchp(/1)
  293. msoupo=ipchp(i)
  294. meleme=igeoc
  295. mpoval=ipoval
  296.  
  297. if (idim.eq.3) then
  298. do j=1,num(/2)
  299. ip=idimp1*(num(1,j)-1)
  300. xmin=min(xcoor(ip+1),xmin)
  301. xmax=max(xcoor(ip+1),xmax)
  302. ymin=min(xcoor(ip+2),ymin)
  303. ymax=max(xcoor(ip+2),ymax)
  304. zmin=min(xcoor(ip+3),zmin)
  305. zmax=max(xcoor(ip+3),zmax)
  306. enddo
  307. else if (idim.eq.2) then
  308. do j=1,num(/2)
  309. ip=idimp1*(num(1,j)-1)
  310. xmin=min(xcoor(ip+1),xmin)
  311. xmax=max(xcoor(ip+1),xmax)
  312. ymin=min(xcoor(ip+2),ymin)
  313. ymax=max(xcoor(ip+2),ymax)
  314. enddo
  315. else
  316. ** else if (idim.eq.1) then
  317. do j=1,num(/2)
  318. ip=idimp1*(num(1,j)-1)
  319. xmin=min(xcoor(ip+1),xmin)
  320. xmax=max(xcoor(ip+1),xmax)
  321. enddo
  322. endif
  323. do 62 ic=1,vpocha(/2)
  324. do 63 iv=1,idim
  325. if (nv(iv).ne.nocomp(ic)) goto 63
  326. do 64 j=1,vpocha(/1)
  327. vmax=max(vmax,abs(vpocha(j,ic)))
  328. 64 continue
  329. 63 continue
  330. 62 continue
  331. 50 continue
  332.  
  333. * if (vmax.le.0.) vmax=1.
  334. if (vmax.le.xpetit) vmax=1.d0
  335. if (.not.(vmax.lt.xsgran)) vmax=xsgran
  336. ampf(nvec)=max(ampf(nvec),(xmax-xmin)/(vmax*10))
  337. if (idim.ge.2) then
  338. ampf(nvec)=max(ampf(nvec),(ymax-ymin)/(vmax*10))
  339. if (idim.ge.3)
  340. & ampf(nvec)=max(ampf(nvec),(zmax-zmin)/(vmax*10))
  341. endif
  342. endif
  343.  
  344. SEGDES MVECTE
  345. CALL ECROBJ ('VECTEUR ',MVECTE)
  346. END
  347.  
  348.  
  349.  
  350.  
  351.  

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