Télécharger opche1.eso

Retour à la liste

Numérotation des lignes :

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

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