Télécharger opche1.eso

Retour à la liste

Numérotation des lignes :

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

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