Télécharger opche1.eso

Retour à la liste

Numérotation des lignes :

  1. C OPCHE1 SOURCE CB215821 18/02/23 21:15:01 9758
  2. SUBROUTINE OPCHE1(IPO1,IOPERA,IARGU,I1,X1,IPO2,IRET)
  3. C=======================================================================
  4. C
  5. C ENTREES
  6. C IPO1 = POINTEUR SUR LE MCHELM
  7. C IPO2 = POINTEUR SUR LE MCHELM (Second Argument ATAN2)
  8. C I1 = ENTIER
  9. C X1 = FLOTTANT
  10.  
  11. C Operations elementaires entre un MCHELM et un ENTIER ou FLOTTANT
  12. C IOPERA= 1 PUISSANCE
  13. C = 2 PRODUIT
  14. C = 3 ADDITION
  15. C = 4 SOUSTRACTION
  16. C = 5 DIVISION
  17. C
  18. C Fonctions sur un MCHELM
  19. C IOPERA= 6 COSINUS
  20. C = 7 SINUS
  21. C = 8 TANGENTE
  22. C = 9 ARCOSINUS
  23. C = 10 ARCSINUS
  24. C = 11 ARCTANGENTE (ATAN A UN ARGUMENT)
  25. C = 12 EXPONENTIELLE
  26. C = 13 LOGARITHME
  27. C = 14 VALEUR ABSOLUE
  28. C = 15 COSINUS HYPERBOLIQUE
  29. C = 16 SINUS HYPERBOLIQUE
  30. C = 17 TANGENTE HYPERBOLIQUE
  31. C = 18 ERF FONCTION D''ERRREUR DE GAUSS
  32. C = 19 ERFC FONCTION D''ERRREUR complementaire DE GAUSS (1-ERF(X))
  33. C = 20 ARGCH (FONCTION RECIPROQUE DE COSH)
  34. C = 21 ARGSH (FONCTION RECIPROQUE DE SINH)
  35. C = 22 ARGTH (FONCTION RECIPROQUE DE TANH)
  36. C
  37. C IARGU = 0 ==> ARGUMENT I1I ET X1I INUTILISES
  38. C IARGU = 1 ==> ARGUMENT I1I UTILISE
  39. C IARGU = 11 ==> ARGUMENT I1I UTILISE MAIS COMMUTE AVEC LE TABLEAU (SOUSTRACTION, DIVISION : POSITIONNEL)
  40. C IARGU = 2 ==> ARGUMENT X1I UTILISE
  41. C IARGU = 21 ==> ARGUMENT X1I UTILISE MAIS COMMUTE AVEC LE TABLEAU (SOUSTRACTION, DIVISION : POSITIONNEL)
  42.  
  43. C SORTIES
  44. C IPO2 = MCHELM SOLUTION
  45. C IRET = 1 SI L OPERATION EST POSSIBLE
  46. C = 0 SI L OPERATION EST IMPOSSIBLE
  47. C
  48. C Creation 05/09/2016
  49. C Createur CB215821
  50. C Historique des Corrections apportees :
  51. C -
  52. C -
  53. C
  54. C=======================================================================
  55.  
  56. IMPLICIT INTEGER(I-N)
  57. IMPLICIT REAL*8 (A-H,O-Z)
  58. C
  59. -INC SMCHAML
  60. -INC SMLREEL
  61. -INC SMLENTI
  62. -INC SMEVOLL
  63. -INC SMLMOTS
  64. -INC CCASSIS
  65. -INC CCOPTIO
  66. -INC TMVALUE
  67. INTEGER IPO1
  68. INTEGER IOPERA
  69. INTEGER IARGU
  70. INTEGER I1
  71. REAL *8 X1
  72. INTEGER IPO2
  73. INTEGER IRET
  74. INTEGER NT1
  75.  
  76. C Segment quelconque pour la desactivation des segements
  77. SEGMENT ISEG(0)
  78.  
  79. EXTERNAL OPTABi
  80. LOGICAL BTHRD
  81.  
  82. C Pour afficher les lignes gibianes appelees decommenter le CALL
  83. C CALL TRBAC
  84. * write(6,*) 'Entree ds opche1',IPO1,IOPERA,IARGU,I1,X1,IPO2,IRET
  85.  
  86.  
  87. MCHEL2 = 0
  88. MELVA2 = 0
  89. MLREE2 = 0
  90. MLENT2 = 0
  91. NN0 = 0
  92. NN1 = 0
  93. N1PTEL = 0
  94. N1PT0 = 0
  95. N1PT1 = 0
  96.  
  97. N1EL = 0
  98. N1EL0 = 0
  99. N1EL1 = 0
  100. NT1 = 0
  101.  
  102. NN2 = 0
  103. N2PTEL = 0
  104. N2EL = 0
  105. N2EL0 = 0
  106. N2EL1 = 0
  107. N2PT0 = 0
  108. N2PT1 = 0
  109.  
  110. C======================================================================C
  111. C Activation des SEGMENTS pour placer les MELVAL dans le SVALUE
  112. C======================================================================C
  113. MCHEL1=IPO1
  114.  
  115. C IF ((IOPERA .EQ. 3) .OR. (IOPERA .EQ. 4)) THEN
  116. CC Pour les operations + - on n'accepte que les MCHAML a 1
  117. CC seule composante.
  118. CC Pour les fonctions, on traite toutes les composantes en présence
  119. C CALL EXTR17(IPO1,MLMOTS)
  120. C SEGACT,MLMOTS
  121. C JGM=MLMOTS.MOTS(/2)
  122. C SEGDES,MLMOTS
  123. C IF(JGM .GT. 1)THEN
  124. C CALL ERREUR(320)
  125. C RETURN
  126. C ENDIF
  127. C ENDIF
  128.  
  129. SEGINI,MCHELM=MCHEL1
  130. N1 = MCHELM.ICHAML(/1)
  131.  
  132. IF (N1 .EQ. 0)THEN
  133. C Cas du MCHELM vide : On renvoie l'IDENTITE
  134. IPO2 = MCHELM
  135. SEGDES,MCHELM
  136. IRET = 1
  137. RETURN
  138. ENDIF
  139.  
  140. C Ajout lecture second argument pour ATAN2 au lieu de ATAN
  141. IF (IPO2 .GT. 0) THEN
  142. MCHEL2=IPO2
  143. SEGACT,MCHEL2
  144. N12=MCHEL2.ICHAML(/1)
  145. C Les deux objets doivent etre de meme taille
  146. IF (N1 .NE. N12 ) THEN
  147. SEGDES,MCHEL2
  148. SEGSUP,MCHELM
  149. CALL ERREUR(329)
  150. RETURN
  151. ENDIF
  152.  
  153. DO I=1,N1
  154. IF (MCHELM.IMACHE(I).NE.MCHEL2.IMACHE(I)) THEN
  155. SEGDES,MCHEL2
  156. SEGSUP,MCHELM
  157. CALL ERREUR(329)
  158. ENDIF
  159. ENDDO
  160. ENDIF
  161. IPO2=MCHELM
  162.  
  163. C Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
  164. C par thread
  165. IOPTIM = 12500
  166.  
  167. NBPOIN=0
  168. IPOS1 =0
  169.  
  170. C Decompte simplement du nombre de TABLEAUX a placer dans le SEGMENT SVALUE
  171. DO IA=1,N1
  172. MCHAM1 = MCHELM.ICHAML(IA)
  173. SEGINI,MCHAML = MCHAM1
  174. MCHELM.ICHAML(IA) = MCHAML
  175. N2 = MCHAML.IELVAL(/1)
  176. DO IB=1,N2
  177. MELVA1 = MCHAML.IELVAL(IB)
  178. SEGACT,MELVA1
  179. N2PT0 = MELVA1.IELCHE(/1)
  180. N2EL0 = MELVA1.IELCHE(/2)
  181. IF (N2PT0 .EQ. 0 .AND. N2EL0.EQ. 0) THEN
  182. C Cas des 'REAL*8'
  183. NBPOIN = NBPOIN + 1
  184. ELSEIF(MCHAML.TYPCHE(IB) .EQ. 'POINTEURLISTREEL' .OR.
  185. & MCHAML.TYPCHE(IB) .EQ. 'POINTEURLISTENTI' ) THEN
  186. NBPOIN = NBPOIN + (N2PT0*N2EL0)
  187. ELSEIF(MCHAML.TYPCHE(IB) .EQ. 'POINTEUREVOLUTIO' ) THEN
  188. DO IEL=1,N2EL0
  189. DO IPEL=1,N2PT0
  190. MEVOL1=MELVA1.IELCHE(IPEL,IEL)
  191. SEGACT,MEVOL1
  192. N=MEVOL1.IEVOLL(/1)
  193. SEGDES,MEVOL1
  194. NBPOIN = NBPOIN + N
  195. ENDDO
  196. ENDDO
  197. ELSE
  198. MOTERR(1:16 ) = MCHAML.TYPCHE(IB)
  199. MOTERR(17:20) = MCHAML.NOMCHE(IB)
  200. MOTERR(21:36) = 'argument '
  201. CALL ERREUR(552)
  202. ENDIF
  203. ENDDO
  204. ENDDO
  205.  
  206. SEGINI,SVALUE
  207.  
  208. DO 40 IA=1,N1
  209. MCHAML=MCHELM.ICHAML(IA)
  210. N2 = MCHAML.IELVAL(/1)
  211.  
  212. C Verif du meme nombre de composante si second argument
  213. IF(MCHEL2 .GT. 0) THEN
  214. MCHAM2 = MCHEL2.ICHAML(IA)
  215. SEGACT,MCHAM2
  216. IF(MCHAM2.IELVAL(/1).NE. N2) THEN
  217. CALL ERREUR(488)
  218.  
  219. DO K = 1,IA
  220. MCHAML = MCHELM.ICHAML(K)
  221. SEGSUP,MCHAML
  222. MCHAM2 = MCHEL2.ICHAML(K)
  223. SEGDES,MCHAM2
  224. ENDDO
  225. ENDIF
  226. ENDIF
  227.  
  228. C Travail sur les COMPOSANTES
  229. DO J = 1,N2
  230. MELVA1 = MCHAML.IELVAL(J)
  231. N1PT0 = MELVA1.VELCHE(/1)
  232. N1EL0 = MELVA1.VELCHE(/2)
  233. N2PT0 = MELVA1.IELCHE(/1)
  234. N2EL0 = MELVA1.IELCHE(/2)
  235.  
  236. NN0 = MAX(N1PT0*N1EL0,N2PT0*N2EL0)
  237.  
  238. C On a donne 2 arguments, des verifications supplementaires sont necessaires
  239. IF(MCHEL2 .GT. 0) THEN
  240. C Verification du Type
  241. IF (MCHAM2.TYPCHE(J) .NE. 'REAL*8') THEN
  242. C Le type %m1:16 de la composante %m17:20 du champ par
  243. C element %m21:36 ne correspond pas a celui attendu
  244. MOTERR(1:16 ) = MCHAM2.TYPCHE(J)
  245. MOTERR(17:20) = MCHAM2.NOMCHE(J)
  246. MOTERR(21:36) = 'argument '
  247. CALL ERREUR(552)
  248. DO K = 1,IA
  249. MCHAML = MCHELM.ICHAML(K)
  250. SEGSUP,MCHAML
  251. ENDDO
  252. SEGSUP,MCHELM
  253. RETURN
  254. ENDIF
  255.  
  256. C Verification des composantes
  257. IF(MCHAML.NOMCHE(J) .NE. MCHAM2.NOMCHE(J)) THEN
  258. CALL ERREUR(488)
  259. DO K = 1,IA
  260. MCHAML = MCHELM.ICHAML(K)
  261. SEGSUP,MCHAML
  262. MCHAM2 = MCHEL2.ICHAML(K)
  263. SEGDES,MCHAM2
  264. ENDDO
  265. SEGDES,MCHEL2
  266. SEGSUP,MCHELM
  267. RETURN
  268. ENDIF
  269.  
  270. MELVA2 = MCHAM2.IELVAL(J)
  271. SEGACT,MELVA2
  272. N1PT1 = MELVA2.VELCHE(/1)
  273. N1EL1 = MELVA2.VELCHE(/2)
  274. N2PT1 = MELVA2.IELCHE(/1)
  275. N2EL1 = MELVA2.IELCHE(/2)
  276. NN1 = MAX(N1PT1*N1EL1,N2PT1*N2EL1)
  277. ENDIF
  278.  
  279. NN2 = MAX(NN0 ,NN1 )
  280. N1PTEL = MAX(N1PT0,N1PT1)
  281. N1EL = MAX(N1EL0,N1EL1)
  282. N2PTEL = MAX(N2PT0,N2PT1)
  283. N2EL = MAX(N2EL0,N2EL1)
  284. SEGINI,MELVAL
  285. MCHAML.IELVAL(J) = MELVAL
  286.  
  287. IF (MCHAML.TYPCHE(J) .EQ. 'REAL*8' ) THEN
  288. IPOS1 = IPOS1 + 1
  289. SVALUE.ITYPOI (IPOS1 )= 2
  290. SVALUE.IPOI0 (IPOS1,1)= MELVA1
  291. SVALUE.IPOI1 (IPOS1,1)= MELVA2
  292. SVALUE.IPOI2 (IPOS1,1)= MELVAL
  293. SVALUE.IPOI0 (IPOS1,2)= NN0
  294. SVALUE.IPOI1 (IPOS1,2)= NN1
  295. SVALUE.IPOI2 (IPOS1,2)= NN2
  296. IF (IPOS1 .EQ. 1) THEN
  297. NT1 = NN2 / IOPTIM
  298. ELSE
  299. NT1 = MAX(NT1, NN2/IOPTIM)
  300. ENDIF
  301.  
  302. ELSEIF(MCHAML.TYPCHE(J) .EQ. 'POINTEURLISTREEL') THEN
  303. MLREE2 = 0
  304. DO IEL=1,N2EL0
  305. DO IPEL=1,N2PT0
  306. MLREE1 = MELVA1.IELCHE(IPEL,IEL)
  307. SEGACT,MLREE1
  308. JG = MLREE1.PROG(/1)
  309. SEGINI,MLREEL
  310. MELVAL.IELCHE(IPEL,IEL) = MLREEL
  311.  
  312. IPOS1 = IPOS1 + 1
  313. SVALUE.ITYPOI (IPOS1 )= 3
  314. SVALUE.IPOI0 (IPOS1,1)= MLREE1
  315. SVALUE.IPOI1 (IPOS1,1)= MLREE2
  316. SVALUE.IPOI2 (IPOS1,1)= MLREEL
  317. SVALUE.IPOI0 (IPOS1,2)= JG
  318. SVALUE.IPOI1 (IPOS1,2)= JG
  319. SVALUE.IPOI2 (IPOS1,2)= JG
  320. IF (IPOS1 .EQ. 1) THEN
  321. NT1 = JG / IOPTIM
  322. ELSE
  323. NT1 = MAX(NT1, JG/IOPTIM)
  324. ENDIF
  325. ENDDO
  326. ENDDO
  327. SEGDES,MELVA1
  328.  
  329. ELSEIF(MCHAML.TYPCHE(J) .EQ. 'POINTEURLISTENTI') THEN
  330. MLENT2 = 0
  331. DO IEL=1,N2EL0
  332. DO IPEL=1,N2PT0
  333. MLENT1 = MELVA1.IELCHE(IPEL,IEL)
  334. SEGACT,MLENT1
  335. JG = MLENT1.LECT(/1)
  336. SEGINI,MLENTI
  337. MELVAL.IELCHE(IPEL,IEL) = MLENTI
  338.  
  339. IPOS1 = IPOS1 + 1
  340. SVALUE.ITYPOI (IPOS1 )= 4
  341. SVALUE.IPOI0 (IPOS1,1)= MLENT1
  342. SVALUE.IPOI1 (IPOS1,1)= MLENT2
  343. SVALUE.IPOI2 (IPOS1,1)= MLENTI
  344. SVALUE.IPOI0 (IPOS1,2)= JG
  345. SVALUE.IPOI1 (IPOS1,2)= JG
  346. SVALUE.IPOI2 (IPOS1,2)= JG
  347. IF (IPOS1 .EQ. 1) THEN
  348. NT1 = JG / IOPTIM
  349. ELSE
  350. NT1 = MAX(NT1, JG/IOPTIM)
  351. ENDIF
  352. ENDDO
  353. ENDDO
  354. SEGDES,MELVA1
  355.  
  356. ELSEIF(MCHAML.TYPCHE(J) .EQ. 'POINTEUREVOLUTIO') THEN
  357. MLREE2 = 0
  358. MLENT2 = 0
  359. DO IEL=1,N2EL0
  360. DO IPEL=1,N2PT0
  361. MEVOL1 = MELVA1.IELCHE(IPEL,IEL)
  362. SEGINI,MEVOLL=MEVOL1
  363. MELVAL.IELCHE(IPEL,IEL)=MEVOLL
  364. N=MEVOLL.IEVOLL(/1)
  365. DO IEV1=1,N
  366. KEVOL1 = MEVOLL.IEVOLL(IEV1)
  367. SEGINI,KEVOLL=KEVOL1
  368. MEVOLL.IEVOLL(IEV1)=KEVOLL
  369. IF (KEVOLL.TYPY .EQ. 'LISTREEL') THEN
  370. MLREE1 = KEVOLL.IPROGY
  371. SEGACT,MLREE1
  372. JG = MLREE1.PROG(/1)
  373. SEGINI,MLREEL
  374. KEVOLL.IPROGY = MLREEL
  375.  
  376. IPOS1 = IPOS1 + 1
  377. SVALUE.ITYPOI (IPOS1 )= 3
  378. SVALUE.IPOI0 (IPOS1,1)= MLREE1
  379. SVALUE.IPOI1 (IPOS1,1)= MLREE2
  380. SVALUE.IPOI2 (IPOS1,1)= MLREEL
  381. SVALUE.IPOI0 (IPOS1,2)= JG
  382. SVALUE.IPOI1 (IPOS1,2)= JG
  383. SVALUE.IPOI2 (IPOS1,2)= JG
  384. IF (IPOS1 .EQ. 1) THEN
  385. NT1 = JG / IOPTIM
  386. ELSE
  387. NT1 = MAX(NT1, JG/IOPTIM)
  388. ENDIF
  389.  
  390. ELSEIF (KEVOLL.TYPY .EQ. 'LISTENTI') THEN
  391. MLENT1 = KEVOLL.IPROGY
  392. SEGACT,MLENT1
  393. JG = MLENT1.LECT(/1)
  394. SEGINI,MLENTI
  395. KEVOLL.IPROGY = MLENTI
  396.  
  397. IPOS1 = IPOS1 + 1
  398. SVALUE.ITYPOI (IPOS1 )= 4
  399. SVALUE.IPOI0 (IPOS1,1)= MLENT1
  400. SVALUE.IPOI1 (IPOS1,1)= MLENT2
  401. SVALUE.IPOI2 (IPOS1,1)= MLENTI
  402. SVALUE.IPOI0 (IPOS1,2)= JG
  403. SVALUE.IPOI1 (IPOS1,2)= JG
  404. SVALUE.IPOI2 (IPOS1,2)= JG
  405. IF (IPOS1 .EQ. 1) THEN
  406. NT1 = JG / IOPTIM
  407. ELSE
  408. NT1 = MAX(NT1, JG/IOPTIM)
  409. ENDIF
  410.  
  411. ELSE
  412. MOTERR(1:8 )=KEVOLL.TYPY
  413. IF (IARGU .EQ. 1 .OR. IARGU .EQ. 11) THEN
  414. MOTERR(9:16)='ENTIER '
  415. CALL ERREUR(532)
  416. ELSEIF (IARGU .EQ. 2 .OR. IARGU .EQ. 21) THEN
  417. MOTERR(9:16)='FLOTTANT'
  418. CALL ERREUR(532)
  419. ELSE
  420. MOTERR(9:16)='???? '
  421. CALL ERREUR(532)
  422. ENDIF
  423. RETURN
  424. ENDIF
  425. SEGDES,KEVOLL
  426. ENDDO
  427. SEGDES,MEVOLL
  428. ENDDO
  429. ENDDO
  430. SEGDES,MELVA1
  431. ELSE
  432. C Le type %m1:16 de la composante %m17:20 du champ par
  433. C element %m21:36 ne correspond pas a celui attendu
  434. MOTERR(1:16 ) = MCHAML.TYPCHE(J)
  435. MOTERR(17:20) = MCHAML.NOMCHE(J)
  436. MOTERR(21:36) = 'argument '
  437. CALL ERREUR(552)
  438. DO K = 1,IA
  439. MCHAML = MCHELM.ICHAML(K)
  440. SEGSUP,MCHAML
  441. ENDDO
  442. SEGSUP,MCHELM
  443. RETURN
  444. ENDIF
  445. ENDDO
  446.  
  447. IF (MCHEL2 .GT. 0) THEN
  448. SEGDES,MCHAM2,MCHAML
  449. ELSE
  450. SEGDES,MCHAML
  451. ENDIF
  452. 40 CONTINUE
  453.  
  454. IF (MCHEL2 .GT. 0) THEN
  455. SEGDES,MCHEL2,MCHELM
  456. ELSE
  457. SEGDES,MCHELM
  458. ENDIF
  459. SVALUE.NPUTIL=IPOS1
  460.  
  461. C======================================================================C
  462. C Partie pour lancer le travail sur les Threads en parallele
  463. C======================================================================C
  464. ITH = 0
  465. IF (NBESC .NE. 0) CALL OOONTH(ITH)
  466. C CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  467. C DEJA DANS LES ASSISTANTS
  468. IF ((NT1 .LE. 1) .OR. (NBTHRS .EQ. 1) .OR. (ITH .GT. 0)) THEN
  469. NBTHR = 1
  470. BTHRD = .FALSE.
  471. ELSE
  472. NBTHR = MIN(NT1, NBTHRS)
  473. BTHRD = .TRUE.
  474. CALL THREADII
  475. ENDIF
  476.  
  477. SEGINI,SPARAL
  478. SPARAL.NBTHRD = NBTHR
  479. SPARAL.IVALUE = SVALUE
  480. SPARAL.IOPE = IOPERA
  481. SPARAL.IARG = IARGU
  482. SPARAL.I1I = I1
  483. SPARAL.X1I = X1
  484.  
  485. IF (BTHRD) THEN
  486. C Remplissage du 'COMMON/optabc'
  487. IPARAL=SPARAL
  488. DO ith=2,NBTHR
  489. CALL THREADID(ith,OPTABi)
  490. ENDDO
  491. CALL OPTABi(1)
  492.  
  493. C Attente de la fin de tous les threads en cours de travail
  494. DO ith=2,NBTHR
  495. CALL THREADIF(ith)
  496. ENDDO
  497.  
  498. C On libère les Threads
  499. CALL THREADIS
  500.  
  501. C Verification de l'erreur (Apres liberation des THREADS)
  502. DO ith=1,NBTHR
  503. IRETOU=SPARAL.IERROR(ith)
  504. IF (IRETOU .GT. 0) THEN
  505. CALL ERREUR(IRETOU)
  506. RETURN
  507. ENDIF
  508. ENDDO
  509.  
  510. C En multithread il peut y avoir n'importe quoi dans OOV(1)
  511. C Indicateur de l'utilisation d'un ELEMENT DE SEGMENT
  512. OOV(1) = 0
  513.  
  514. ELSE
  515. C Appel de la SUBROUTINE qui fait le travail
  516. CALL OPTAB0(1,SPARAL)
  517.  
  518. IRETOU=SPARAL.IERROR(1)
  519. IF (IRETOU .GT. 0) THEN
  520. CALL ERREUR(IRETOU)
  521. RETURN
  522. ENDIF
  523. ENDIF
  524.  
  525. C======================================================================C
  526. C Boucle pour desactiver les SEGMENTS
  527. C======================================================================C
  528. DO 50 IA=1,SVALUE.NPUTIL
  529. ISEG = SVALUE.IPOI0(IA,1)
  530. IF (ISEG.NE.0) SEGDES,ISEG
  531. ISEG = SVALUE.IPOI1(IA,1)
  532. IF (ISEG.NE.0) SEGDES,ISEG
  533. ISEG = SVALUE.IPOI2(IA,1)
  534. IF (ISEG.NE.0) SEGDES,ISEG
  535. 50 CONTINUE
  536. SEGSUP,SVALUE
  537.  
  538. IRET = 1
  539. RETURN
  540. END
  541.  
  542.  
  543.  

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