Télécharger muchp1.eso

Retour à la liste

Numérotation des lignes :

  1. C MUCHP1 SOURCE PV 20/03/30 21:21:24 10567
  2. SUBROUTINE MUCHP1(IPOI1,IPOI2,LMOT1,LMOT2,LMOT3,IPLREE,IEPS,IRET)
  3. C=======================================================================
  4. C
  5. C entree
  6. C ipoi1=chpoint
  7. C ipoi2=chpoint
  8. C lmot1=liste de mots1
  9. C lmot2=liste de mots2
  10. C lmot3=liste de mots3
  11. C sorties
  12. C iret = pointeur sur chpoint resultant
  13. C = 0 sinon (un message d erreur est alors imprime )
  14. C
  15. C 2018/01/19 gounand ajout du listreel de ponderation
  16. C
  17. C======================================================================
  18. IMPLICIT INTEGER(I-N)
  19. IMPLICIT REAL*8(A-H,O-Z)
  20. -INC SMCHPOI
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMELEME
  25. -INC SMLMOTS
  26. -INC SMCOORD
  27. -INC SMLREEL
  28.  
  29. C le tableau icpr contient la mise en ordre des 3 chpoint
  30. SEGMENT ICPR
  31. C nbre harm. comp points chpoints
  32. REAL*8 VALCPR(nbpts,NCOMP1,NHAR)
  33. ENDSEGMENT
  34. C nocmp1 et le nombre de composante dans chaque listmot
  35. C nhar est le nombre d'harmonique de Fourrier présent
  36. C ce segment contient les numéro des différents harmoniques trouvées
  37. C et l'inversion du tableau
  38. SEGMENT NUMHAR(NHAR)
  39. SEGMENT IHARNU(NVHAR)
  40. C ce tableau sert de correspondance entre les composantes des liste mot
  41. C et celles des champ point pour chaque sous zone
  42. SEGMENT ICOR1(NCOMP1)
  43. SEGMENT ICOR2(NCOMP1)
  44. C
  45. C ces segment servent au moment de l'assemblage du nouveau chpoint
  46. C celui stocke le nombre de sous zone du nouveau chpoint
  47. SEGMENT JCHACO(4,NSOUP1)
  48. C indice 1 et 2 voir muchpo2 , 3 nombre de pts , 4 nbre de composante
  49. C kchaco donne l'adresse dans jchaco de la sous zone
  50. SEGMENT KCHACO(NSOUPO)
  51. SEGMENT MCORES
  52. C correspondence comp listmot comp sous zone
  53. INTEGER ICOR3(NCOMP1,NSOUPO)
  54. C indice 1 contient sum 2**i si i présent
  55. C indice 2 contient le nombre de i present
  56. INTEGER KCOMP(2,NSOUPO)
  57. INTEGER KHARM(NSOUPO)
  58. ENDSEGMENT
  59.  
  60.  
  61. LOGICAL IVCHPO
  62.  
  63.  
  64. C
  65. C ce tableau contient les pointeurs des deux champ point et des listemots
  66. DIMENSION ICHP(2),ILMO(2),NR(2)
  67. CHARACTER*4 MOTCLE(3),MONATU(1)
  68. DATA MOTCLE/'INDE','DIFF','DISC'/
  69. DATA MONATU/'NATU'/
  70. C
  71. C executable
  72. IRET=0
  73. C verification de la dimension des listmots
  74. MLMOT1=LMOT1
  75. MLMOT2=LMOT2
  76. MLMOT3=LMOT3
  77. MLREE3=0
  78. SEGACT MLMOT1,MLMOT2,MLMOT3
  79. NCOMP1 = MLMOT1.MOTS(/2)
  80. NCOMP2 = MLMOT2.MOTS(/2)
  81. NCOMP3 = MLMOT3.MOTS(/2)
  82. IF (NCOMP1.NE.NCOMP2.OR.NCOMP3.NE.NCOMP1) THEN
  83. C erreur dans la dimension des lismots
  84. CALL ERREUR(854)
  85. *new-paradigme SEGDES MLMOT1,MLMOT2,MLMOT3
  86. RETURN
  87. ENDIF
  88. if (IPLREE.gt.0) then
  89. MLREE3 = IPLREE
  90. segact mlree3
  91. if (mlree3.prog(/1).ne.ncomp1) then
  92. *new-paradigme segdes,mlmot1,mlmot2,mlmot3,mlree3
  93. MOTERR(1:8)='LIST****'
  94. MOTERR(9:16)='termes '
  95. call erreur(403)
  96. return
  97. endif
  98. endif
  99.  
  100. C determination du nombre d'harmonique de Fourrier
  101. C expédition rapide du cas sans harmonique
  102. NR(1) = 0
  103. NR(2) = 0
  104. ILMO(1)=LMOT1
  105. ILMO(2)=LMOT2
  106. ICHP(1)= IPOI1
  107. ICHP(2)= IPOI2
  108. C
  109. MCHPO1 = IPOI1
  110. MCHPO2 = IPOI2
  111. SEGACT MCHPO1,MCHPO2
  112. NHAR = 1
  113. NSUM = 0
  114. C boucle sur les 2 champoints
  115. DO 300 K=1,2
  116. MCHPO1 = ICHP(K)
  117. DO 200 I=1,MCHPO1.IPCHP(/1)
  118. MSOUPO = MCHPO1.IPCHP(I)
  119. SEGACT MSOUPO
  120. MELEME = IGEOC
  121. SEGACT MELEME
  122. NR(K) = NR(K) + NUM(/2)
  123. *new-paradigme SEGDES MELEME
  124. DO 100 J=1,NOHARM(/1)
  125. NSUM = NSUM + NOHARM(J)
  126. 100 CONTINUE
  127. 200 CONTINUE
  128. 300 CONTINUE
  129. C
  130. C combien y a t'il d'harmoniques ?
  131. C
  132. IF (NSUM .NE. 0) THEN
  133. C il y en a plusieurs
  134. C write(6,*) 'Appel de noharm'
  135. CALL NHARMO(IPOI1,IPOI2,NHAR,NUMHAR,NMIN,IHARNU)
  136. NVHAR=IHARNU(/1)
  137. ELSE
  138. C cas simple toutes les harmoniques sont nulles
  139. NHAR = 1
  140. NVHAR= 1
  141. SEGINI NUMHAR,IHARNU
  142. NUMHAR(1)=0
  143. IHARNU(1)=1
  144. NMIN=0
  145. ENDIF
  146. C
  147. C write(6,*) 'points',nbpts,'Comp',ncomp1,'nhar',nhar
  148. C
  149. C initialisation du tableau
  150. SEGINI ICPR
  151. C ordre des opérations
  152. C cela va dépendre des remplissage respectifs NR1 et NR2
  153. C
  154. NRR1 = MAX(NR(1),NR(2))
  155. NRR2 = MIN(NR(1),NR(2))
  156. DNRR1 = REAL(NRR1)
  157. DNRR2 = REAL(NRR2)
  158. TAUX = DNRR2 / (DNRR1+0.1)
  159. C write(6,*) 'Taux de remplissage',taux
  160. C on classe les champ point dans l'ordre de taille
  161. IF ((NRR1.NE.NR(1).AND.TAUX.LT.0.5).OR.
  162. & (NRR1.EQ.NR(1).AND.TAUX.GE.0.5)) THEN
  163. C write(6,*) 'Inversion de l ordre des champoints'
  164. C write(6,*) 'Taux de remplissage' ,taux
  165. IDUM1 = ICHP(1)
  166. IDUM2 = ILMO(1)
  167. ICHP(1)=ICHP(2)
  168. ILMO(1)=ILMO(2)
  169. ICHP(2)=IDUM1
  170. ILMO(2)=IDUM2
  171. IVCHPO=.TRUE.
  172. ELSE
  173. IVCHPO=.FALSE.
  174. ENDIF
  175. C remplissage du tableau en bouclant sur les champ par points
  176. C on boucle sur les deux champ point
  177. C pour chaque sous zone on établi la correspondance de composantes du
  178. C liste mots vers les nom de composantes de la sous zone
  179. SEGINI ICOR1,ICOR2
  180. C pseudo boucle sur les champ points
  181. MCHPOI = ICHP(1)
  182.  
  183. MLMOTS = ILMO(1)
  184. DO 900 J=1,IPCHP(/1)
  185. MSOUPO = IPCHP(J)
  186. C on établi la correspondance de composantes du
  187. C liste mots vers les nom de composantes de la sous zone
  188. NC = NOHARM(/1)
  189. NC1 = 0
  190. DO 600 K=1,NCOMP1
  191. ICOR1(K)=0
  192. DO 500 L=1,NC
  193. C write(6,*) MOTS(K),NOCOMP(L)
  194. IF(MOTS(K).EQ.NOCOMP(L)) THEN
  195. C write(6,*) 'chp1 sz',j,'ccomp',l,'lcomp',k
  196. ICOR1(K)=L
  197. C nbre de composante présente sur la sous zone
  198. NC1 = NC1 + 1
  199. ICOR2(NC1)=K
  200. GOTO 600
  201. ENDIF
  202. 500 CONTINUE
  203. 600 CONTINUE
  204.  
  205. C on remplit chaque point du meleme
  206. MELEME = IGEOC
  207. MPOVAL = IPOVAL
  208. SEGACT MELEME,MPOVAL
  209. C boucle sur les composantes
  210. DO 800 K=1,NC1
  211. KK = ICOR2(K)
  212. LC = ICOR1(KK)
  213. C numero local de l'harmonique
  214. IHA = IHARNU(NOHARM(LC)-NMIN+1)
  215. C boucle sur les points
  216. DO 700 L=1,NUM(/2)
  217. NBP = NUM(1,L)
  218. C remplissage ici
  219. VALCPR(NBP,KK,IHA)
  220. & =VPOCHA(L,LC)
  221. 700 CONTINUE
  222. 800 CONTINUE
  223. *new-paradigme SEGDES MELEME,MPOVAL,MSOUPO
  224. 900 CONTINUE
  225. C
  226. C on passe au second champ point
  227. MCHPOI = ICHP(2)
  228. MLMOTS = ILMO(2)
  229. DO 1400 J=1,IPCHP(/1)
  230. MSOUPO = IPCHP(J)
  231. SEGACT MSOUPO
  232. C on établi la correspondance de composantes du
  233. C liste mots vers les nom de composantes de la sous zone
  234. NC = NOHARM(/1)
  235. NC1 = 0
  236. C
  237. ncomp1 = mots(/2)
  238. C
  239. DO 1100 K=1,NCOMP1
  240. ICOR1(K)=0
  241. DO 1000 L=1,NC
  242. C write(6,*) 'mots=',MOTS(K),'Comp=',NOCOMP(L)
  243. IF(MOTS(K).EQ.NOCOMP(L)) THEN
  244. C write(6,*) 'chp2 sz',j,'ccomp',l,'lcomp',k
  245. ICOR1(K)=L
  246. C nbre de composante présente sur la sous zone
  247. NC1 = NC1 + 1
  248. ICOR2(NC1)=K
  249. GOTO 1100
  250. ENDIF
  251. 1000 CONTINUE
  252. 1100 CONTINUE
  253.  
  254. C on remplit chaque point du meleme
  255. MELEME = IGEOC
  256. MPOVAL = IPOVAL
  257. SEGACT MELEME,MPOVAL
  258. C boucle sur les composantes
  259. DO 1300 K=1,NC1
  260. KK = ICOR2(K)
  261. LC = ICOR1(KK)
  262. C numero local de l'harmonique
  263. IHA = IHARNU(NOHARM(LC)-NMIN+1)
  264. C boucle sur les points
  265. DO 1200 L=1,NUM(/2)
  266. NBP = NUM(1,L)
  267. C multiplication ou division ici
  268. IF (IEPS.EQ.1) THEN
  269. VALCPR(NBP,KK,IHA)
  270. & =VALCPR(NBP,KK,IHA)*VPOCHA(L,LC)
  271. ELSE
  272. IF (IVCHPO) THEN
  273. VALCPR(NBP,KK,IHA)
  274. & =VPOCHA(L,LC)/VALCPR(NBP,KK,IHA)
  275. ELSE
  276. VALCPR(NBP,KK,IHA)
  277. & =VALCPR(NBP,KK,IHA)/VPOCHA(L,LC)
  278. ENDIF
  279. ENDIF
  280. 1200 CONTINUE
  281. 1300 CONTINUE
  282. *new-paradigme SEGDES MELEME,MPOVAL
  283. 1400 CONTINUE
  284. SEGSUP ICOR1,ICOR2
  285. C
  286. C
  287. C impression de icpr
  288. C WRITE(6,*) 'PTS',nbpts,'COMP',ncomp1,'Nhar',nhar
  289. C do 6003 i=1,nbpts
  290. C write(6,5001) i
  291. C do 6002 j=1,ncomp1
  292. C do 6001 k=1,nhar
  293. C write(6,5002) j,k,valcpr(i,j,k)
  294. C 6001 continue
  295. C 6002 continue
  296. C 6003 continue
  297.  
  298. C 5001 format('Point numero',I4)
  299. C 5002 format('Composante',I2,'Harmonique',I2,'Valeur',G12.5)
  300.  
  301.  
  302. C
  303. C il faut maintenant creer le champ point résultat
  304. C on commence par
  305. MCHPOI=ICHP(2)
  306. MLMOTS=ILMO(2)
  307. C
  308. C muchp2 determine le nombre de sous zone de notre chpoint
  309. C
  310. C write(6,*) 'Appel à muchp2'
  311. CALL MUCHP2(MCHPOI,MLMOTS,MCORES,JCHACO,KCHACO,IHARNU,NMIN)
  312. C en sortie de mcuchp2 les segment sont actifs
  313. C
  314. C création du nouveau champ par point
  315. C
  316. C nini = jchaco(/2)
  317. C write(6,*)'tableau jchaco 1: kcomp 2:khar 3:nbre pts 4:nb comp'
  318. C do 6005 i=1,nini
  319. C write(6,5003) jchaco(1,i),jchaco(2,i),jchaco(3,i),jchaco(4,i)
  320. C 6005 continue
  321. C 5003 format(' ',4(I5,2X))
  322. C
  323. C nini = kchaco(/1)
  324. C write(6,*)'tableau kchaco correspondace 1 -> 3'
  325. C write(6,5004) (kchaco(i),i=1,nini)
  326. C 5004 format(' ',6(I2,2X))
  327. C
  328. C write(6,*) 'Tableau mcores - icor3'
  329. C nono = icor3(/1)
  330. C write(6,*) 'icor3(/1)=' ,nono
  331. C do 6004 i=1,nini
  332. C write(6,*) 'sous zone' , i
  333. C write(6,5005) (icor3(j,i),j=1,nono)
  334. C 6004 continue
  335. C 5005 format(10(I2,2X))
  336. C
  337. C attention inversion volontaire
  338. MCHPO1 = ICHP(2)
  339. MCHPO2 = ICHP(1)
  340. NSOUPO = JCHACO(/2)
  341. NAT = 1
  342. SEGINI MCHPO3
  343. NSOUP1 = NSOUPO
  344. NSOUPO= MCHPO1.IPCHP(/1)
  345. MCHPO3.MOCHDE = 'PRODUIT DE DEUX CHAMP POINT PAR *'
  346. MCHPO3.MTYPOI = ' '
  347.  
  348. C nature du champoint
  349. CALL LIRMOT(MONATU,1,IVAL,0)
  350. IF ( IVAL .EQ.1 ) THEN
  351. CALL LIRMOT(MOTCLE,3,IVAL,1)
  352. IF ( IERR .NE. 0) RETURN
  353. MCHPO3.JATTRI(1) = IVAL-1
  354. ELSE
  355. NATRI = MCHPO1.JATTRI(1) * MCHPO2.JATTRI(1)
  356. IF ( NATRI .EQ. 0) THEN
  357. MCHPO3.JATTRI(1) = 0
  358. ELSE IF ( NATRI .EQ. 1) THEN
  359. MCHPO3.JATTRI(1) = 1
  360. ELSE IF ( NATRI .EQ. 2) THEN
  361. C la nature discrete domine
  362. MCHPO3.JATTRI(1) = 2
  363. ELSE
  364. MCHPO3.JATTRI(1) = 2
  365. ENDIF
  366. ENDIF
  367. MCHPO3.IFOPOI = IFOUR
  368. C
  369. C boucle sur les sous zones DE MCHPO3
  370. C
  371. DO 2200 I=1,NSOUP1
  372. NC = JCHACO(4,I)
  373. NBELEM=JCHACO(3,I)
  374. C cas ou la sous zone n'existe pas encore
  375. SEGINI MSOUP3
  376. MCHPO3.IPCHP(I)=MSOUP3
  377. NBNN = 1
  378. C on cherche la première sous zone correspondante
  379. DO 1500 J=I,NSOUPO
  380. IF (KCHACO(J).EQ.I) GOTO 1600
  381. 1500 CONTINUE
  382. C ici j est le numéro de la premièer sous zone de mchpo1 correspondante
  383. 1600 CONTINUE
  384. MSOUP1 = MCHPO1.IPCHP(J)
  385. SEGACT MSOUP1
  386. IPT1 = MSOUP1.IGEOC
  387. SEGACT IPT1
  388. IF (NBELEM.EQ.IPT1.NUM(/2)) THEN
  389. IPT3 = IPT1
  390. ELSE
  391. NBSOUS = 0
  392. NBREF = 0
  393. NBNN = 1
  394. SEGINI IPT3
  395. DO 1650 K=1,IPT1.NUM(/2)
  396. IPT3.NUM(1,K)=IPT1.NUM(1,K)
  397. 1650 CONTINUE
  398. ENDIF
  399. MSOUP3.IGEOC = IPT3
  400. NR3 = IPT1.NUM(/2)
  401. N = NBELEM
  402. SEGINI MPOVA3
  403. MSOUP3.IPOVAL= MPOVA3
  404. C
  405. C nom des composantes et harmoniques
  406. C
  407. IC = 0
  408. DO 1800 K=1,NCOMP1
  409. IF (ICOR3(K,J).NE.0) THEN
  410. IC = IC + 1
  411. MSOUP3.NOCOMP(IC) = MLMOT3.MOTS(K)
  412. MSOUP3.NOHARM(IC) = MSOUP1.NOHARM(ICOR3(K,J))
  413. MSOUP3.NOCONS(IC) = MSOUP1.NOCONS(ICOR3(K,J))
  414. C
  415. C 1 ier remplissage
  416. C
  417. DO 1700 L=1,IPT1.NUM(/2)
  418. NBP = IPT1.NUM(1,L)
  419. XVAL=VALCPR(NBP,K,IHARNU(MSOUP3.NOHARM(IC)-NMIN+1))
  420. IF (mlree3.ne.0) xval=xval*mlree3.prog(k)
  421. MPOVA3.VPOCHA(L,IC)=XVAL
  422. 1700 CONTINUE
  423. ENDIF
  424. 1800 CONTINUE
  425. *new-paradigme SEGDES MSOUP1,IPT1
  426. C
  427. C remplissage suivant
  428. C
  429. C write(6,*) 'nr3=',nr3,'nbelem=',nbelem
  430. IF (NR3 .NE. NBELEM) THEN
  431. C write(6,*) 'Compactage de la sous zone'
  432. C on cherche la prochaine sous zone correspondante
  433. DO 2100 K=J+1,NSOUPO
  434. IF (KCHACO(K).EQ.I) THEN
  435. C k est le numéro de la sous zone de mchpo1
  436. MSOUP1 = MCHPO1.IPCHP(K)
  437. SEGACT MSOUP1
  438. IPT1 = MSOUP1.IGEOC
  439. SEGACT IPT1
  440. IC = 0
  441. DO 2000 L=1,NCOMP1
  442. IF (ICOR3(L,K).NE.0) THEN
  443. IC = IC + 1
  444. DO 1900 M=1,IPT1.NUM(/2)
  445. NBP = IPT1.NUM(1,M)
  446. IPT3.NUM(1,NR3+M) = NBP
  447. XVAL=VALCPR(NBP,L,IHARNU(MSOUP3.NOHARM(IC)
  448. $ -NMIN+1))
  449. IF (mlree3.ne.0) xval=xval*mlree3.prog(L)
  450. MPOVA3.VPOCHA(NR3+M,IC)=XVAL
  451. 1900 CONTINUE
  452. ENDIF
  453. 2000 CONTINUE
  454. NR3 = NR3 + IPT1.NUM(/2)
  455. *new-paradigme SEGDES MSOUP1,IPT1
  456. ENDIF
  457. 2100 CONTINUE
  458. IF ( NR3.NE.NBELEM.OR.NC.NE.IC)THEN
  459. C write(6,*)'nr3',nr3,'nbelem',nbelem,'nc',nc,'ic',ic
  460. WRITE(IOIMP,*) 'erreur dans muchpo1.eso'
  461. CALL ERREUR(5)
  462. RETURN
  463. ENDIF
  464. C on ferme la sous zone du nouveau chpoint
  465.  
  466. ENDIF
  467. *new-paradigme SEGDES IPT3,MPOVA3,MSOUP3
  468. 2200 CONTINUE
  469. *new-paradigme SEGDES MCHPO2,MCHPO1,MCHPO3
  470. C on détruit les temporaires
  471. SEGSUP ICPR,IHARNU,NUMHAR,JCHACO,KCHACO,MCORES
  472. *new-paradigme SEGDES ,MLMOT1,MLMOT2,MLMOT3
  473. *new-paradigme if (mlree3.ne.0) segdes mlree3
  474. IRET = MCHPO3
  475. RETURN
  476. END
  477.  
  478.  
  479.  
  480.  
  481.  
  482.  
  483.  
  484.  
  485.  
  486.  

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