Télécharger kops.eso

Retour à la liste

Numérotation des lignes :

  1. C KOPS SOURCE PV 16/11/17 22:00:16 9180
  2. C Retour à la version de Stéphane
  3. C KOPS SOURCE GOUNAND 11/05/25 21:15:20 6980
  4. SUBROUTINE KOPS
  5. C*************************************************************************
  6. C
  7. C cet operateur effectue des operations speciales entre les CHPOINT-TRIO
  8. C
  9. C
  10. C
  11. C
  12. C*************************************************************************
  13.  
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8 (A-H,O-Z)
  16.  
  17. -INC CCOPTIO
  18. -INC SMTABLE
  19. -INC SMLMOTS
  20. -INC SMLENTI
  21. -INC SMELEME
  22. POINTEUR MELEMC.MELEME
  23. -INC SMCOORD
  24.  
  25. POINTEUR MAT1.MATRIK,MAT2.MATRIK,MAT3.MATRIK,IMAT1.IMATRI
  26.  
  27. * -INC SMRIGID
  28. *
  29. * OBJET RIGIDITE
  30. *
  31. SEGMENT STCOUP
  32. INTEGER MCOUP(nicd,nicp)
  33. ENDSEGMENT
  34.  
  35. SEGMENT MRIGID
  36. CHARACTER*8 MTYMAT
  37. REAL*8 COERIG(NRIGEL)
  38. INTEGER JRIGEL(8,NRIGEL)
  39. INTEGER ICHOLE,IMGEO1,IMGEO2,IFORIG
  40. INTEGER ISUPEQ,JRCOND,JRDEPP,JRDEPD
  41. INTEGER JRELIM,JRGARD,JRTOT,IMLAG
  42. INTEGER IPROFO,IVECRI
  43. ENDSEGMENT
  44. -INC SMCHPOI
  45. C POINTEUR IZV1.MCHPOI,IZVV1.MPOVAL
  46. C POINTEUR IZV2.MCHPOI,IZVV2.MPOVAL
  47.  
  48. DIMENSION XVEC(3),ITINC(100)
  49. INTEGER JMOTS
  50. CHARACTER*8 TYPE,TYPC,TYPE1,TYPE2
  51. PARAMETER (NBOP=32)
  52. CHARACTER*4 MOT4,NOMTOT(10)
  53. CHARACTER*8 LOPER(NBOP),MTYP,NOMI,NOM,NOMC,NOMK,LXNM
  54. CHARACTER*8 NOMKP,NOMKD
  55. CHARACTER*8 BLAN
  56. DATA BLAN/' '/
  57. DATA LOPER/'MULT ','DIVI ','........','........','ET ',
  58. & '* ','/ ','+ ','- ','** ',
  59. & '|< ','>| ','GRAD ','ROT ','CLIM ',
  60. & 'INV ','MATRAK ','MATRIK ','VNIMP ','VTIMP ',
  61. & 'MTABX ','CMCTSPLT','MATIDE ','RIGIDITE','GRADS ',
  62. & 'EXTRCOMP','EXTRMASS','EXTRPREC','CHANINCO','TRANSPOS',
  63. & 'MATDIAGO','EXTRCOUP'/
  64. C***
  65. JMOTS =0
  66. NAG =0
  67. NBMAT =0
  68. IKASS =0
  69. MCHPO1=0
  70. MCHPO2=0
  71. MCHPOI=0
  72. XVAL1 =0.
  73. XVAL2 =0.
  74. NFLOT =0
  75. MTABD =0
  76.  
  77. C ********************************************
  78. C * La premiere partie de cette routine *
  79. C * consiste a recuperer les arguments de *
  80. C * l operateur KOPS afin de pouvoir leurs *
  81. C * attribuer le traitement correspondant *
  82. C ********************************************
  83.  
  84. 10 CONTINUE
  85. C On saisit le premier objet de la pile
  86. C *************************************
  87.  
  88. CALL QUETYP(MTYP,0,IRET)
  89. IF(IRET.EQ.0)GO TO 9
  90. C write(6,*)' KOPS nag=',NAG,' MTYP=',MTYP
  91.  
  92. C ============================================
  93. C Cas : Objet = MOT
  94. C ============================================
  95. IF(MTYP.EQ.'MOT')THEN
  96. JMOTS=1
  97.  
  98. C? CALL LIRCHA(MMOP,1,NBC)
  99. C? CALL OPTLI(KOP,LOPER,MMOP,NBOP)
  100.  
  101. CALL LIRMOT(LOPER,NBOP,KOP,0)
  102. C write(6,*)' KOPS ',LOPER(KOP)
  103. IF(KOP.EQ.0)THEN
  104. CALL RYO2V(IRET)
  105. IF(IRET.EQ.0)RETURN
  106. WRITE(6,*)' Opérateur KOPS :',KOP
  107. WRITE(6,*)' Operation inconnue '
  108. RETURN
  109. ENDIF
  110.  
  111. C Cas tres tres particulier(s)
  112.  
  113. C CAS KOP=17
  114. IF(KOP.EQ.17)THEN
  115. NRIGE=8
  116. NMATRI=0
  117. NKID =9
  118. NKMT =7
  119. SEGINI MATRIK
  120. SEGDES MATRIK
  121. CALL ECROBJ('MATRIK',MATRIK)
  122.  
  123. RETURN
  124. ENDIF
  125.  
  126. C CAS KOP=18
  127. IF(KOP.EQ.18)THEN
  128. NRIGE=7
  129. NMATRI=0
  130. NKID =9
  131. NKMT =7
  132. SEGINI MATRIK
  133. SEGDES MATRIK
  134. CALL ECROBJ('MATRIK',MATRIK)
  135.  
  136. NAT=2
  137. NSOUPO=0
  138. SEGINI MCHPOI
  139. JATTRI(1)=2
  140. IFOPOI = IFOUR
  141. SEGDES MCHPOI
  142. CALL ECROBJ('CHPOINT',MCHPOI)
  143.  
  144. RETURN
  145. ENDIF
  146.  
  147. C CAS KOP=19
  148. IF(KOP.EQ.19)THEN
  149.  
  150. CALL VNIMP
  151.  
  152. RETURN
  153. ENDIF
  154.  
  155. C CAS KOP=20
  156. IF(KOP.EQ.20)THEN
  157.  
  158. CALL VTIMP
  159.  
  160. RETURN
  161. ENDIF
  162.  
  163. C CAS KOP=21 MTABX
  164. IF(KOP.EQ.21)THEN
  165.  
  166. CALL LIROBJ('TABLE',MTABX,1,IRET)
  167. IF(IRET.EQ.0)RETURN
  168. CALL LIRREE(DTR,1,IRET)
  169. IF(IRET.EQ.0)RETURN
  170. KKIZG=0
  171. TYPE=' '
  172. CALL ACMO(MTABX,'KIZG',TYPE,KIZG)
  173. IF(KIZG.NE.0)THEN
  174. TYPE=' '
  175. CALL ACMO(MTABX,'LISTINCO',TYPE,MLMOTS)
  176. IF(MLMOTS.EQ.0)RETURN
  177. SEGACT MLMOTS
  178. NBMOT=MOTS(/2)
  179. DO 36476 I=1,NBMOT
  180. NOMI=MOTS(I)
  181. TYPE=' '
  182. CALL ACMO(KIZG,NOMI,TYPE,MCHPOI)
  183. IF(TYPE.NE.'CHPOINT')GO TO 36476
  184. SEGACT MCHPOI
  185. NSOUPO=IPCHP(/1)
  186. IF(NSOUPO.NE.1)RETURN
  187. MSOUPO=IPCHP(1)
  188. SEGACT MSOUPO
  189. NC=NOCOMP(/2)
  190. DO 36477 J=1,NC
  191. IF(NC.NE.1.AND.NC.LT.10)THEN
  192. WRITE(MOT4,FMT='(I1,A3)')J,NOMI(1:3)
  193. ELSEIF(NC.EQ.1)THEN
  194. WRITE(MOT4,FMT='(A4)')NOMI
  195. ELSE
  196. RETURN
  197. ENDIF
  198. NOCOMP(J)=MOT4
  199. 36477 CONTINUE
  200. KKIZG=1
  201. CALL ECROBJ('CHPOINT ',MCHPOI)
  202. CALL ECRREE(-1.D0)
  203. CALL OPERMU
  204. IF(I.GT.1)CALL OPERAD
  205. 36476 CONTINUE
  206. ENDIF
  207.  
  208. IF(KKIZG.NE.0)THEN
  209. CALL ECRREE(DTR)
  210. CALL OPERMU
  211. ENDIF
  212.  
  213. TYPE=' '
  214. CALL ACMO(MTABX,'SMBR',TYPE,MCHPOI)
  215. IF(TYPE.EQ.'CHPOINT')THEN
  216. CALL ECROBJ('CHPOINT ',MCHPOI)
  217. IF(KKIZG.NE.0)CALL OPERAD
  218. ELSE
  219. IF(KKIZG.EQ.0)CALL ECRREE(1.D0)
  220. ENDIF
  221.  
  222. CALL ECME(MTABX,'SMBR',1)
  223.  
  224. RETURN
  225. ENDIF
  226.  
  227. C CAS KOP=22
  228. IF(KOP.EQ.22)THEN
  229.  
  230. CALL SPLTCC
  231.  
  232. RETURN
  233. ENDIF
  234.  
  235. C KAS KOP=23 ('MATIDE')
  236.  
  237. IF(KOP .EQ. 23)THEN
  238. CALL KOPSID
  239. RETURN
  240. ENDIF
  241.  
  242. C CAS KOP=24
  243. IF(KOP.EQ.24)THEN
  244. NRIGE=8
  245. NRIGEL=0
  246. SEGINI MRIGID
  247. SEGDES MRIGID
  248. CALL ECROBJ('RIGIDITE',MRIGID)
  249.  
  250. NAT=2
  251. NSOUPO=0
  252. SEGINI MCHPOI
  253. JATTRI(1)=2
  254. IFOPOI = IFOUR
  255. SEGDES MCHPOI
  256. CALL ECROBJ('CHPOINT',MCHPOI)
  257.  
  258. RETURN
  259. ENDIF
  260. C
  261. C CAS KOP=25 'GRADS'
  262. IF(KOP.EQ.25)THEN
  263. GO TO 10
  264. ENDIF
  265. C
  266. C CAS KOP=26 'EXTRCOMP'
  267. IF(KOP.EQ.26)THEN
  268. CALL LIRCHA(NOMC,1,IRET)
  269. CALL LIRCHA(NOMK,1,IRET)
  270. IF(IRET.EQ.0)RETURN
  271. CALL LIROBJ('MATRIK',MAT1,1,IRET)
  272. IF(IRET.EQ.0)RETURN
  273.  
  274. SEGACT MAT1
  275. NRIGE =MAT1.IRIGEL(/1)
  276. NMATRI=MAT1.IRIGEL(/2)
  277. NMATRI=0
  278. NKID =MAT1.KIDMAT(/1)
  279. NKMT =MAT1.KKMMT(/1)
  280. SEGINI MATRIK
  281. CALL RSETI(KIDMAT,MAT1.KIDMAT,NKID)
  282. CALL RSETI(KKMMT ,MAT1.KKMMT ,NKMT)
  283. KSYM = MAT1.KSYM
  284. mincp= MAT1.KMINC
  285. if(mincp.ne.0)then
  286. segact mincp
  287. nbi= mincp.LISINC(/2)
  288. npt= mincp.NPOS(/1)-1
  289. segini minc
  290. call rseti(npos,mincp.npos,npt+1)
  291. call rseti(mpos,mincp.mpos,(npt*(nbi+1)))
  292. lisinc(1)=NOMK
  293. if(nbi.ne.1)then
  294. write(6,*)' Gross Pb NBI=',nbi
  295. write(6,*)(mincp.lisinc(ii),ii=1,nbi)
  296. call arret (0)
  297. endif
  298. KMINC = minc
  299. KMINCP= minc
  300. KMINCD= minc
  301. endif
  302.  
  303. KIZM = MAT1.KIZM
  304.  
  305. KISPGT= MAT1.KISPGT
  306. KISPGP= MAT1.KISPGP
  307. KISPGD= MAT1.KISPGD
  308.  
  309. KNTTT = MAT1.KNTTT
  310. KNTTP = MAT1.KNTTP
  311. KNTTD = MAT1.KNTTD
  312.  
  313. NMATR1=MAT1.IRIGEL(/2)
  314. c write(6,*)'NMATR1=',NMATR1
  315. do 6432 lm=1, NMATR1
  316. IMAT1=MAT1.irigel(4,lm)
  317. segact imat1
  318. nbmf=IMAT1.LISPRI(/2)
  319. c write(6,*)' NBMF=',nbmf
  320.  
  321. LXNM='LX'//NOMC(1:2)
  322. do 6433 lmf=1,nbmf
  323. NOMKP=NOMK
  324. NOMKD=NOMK
  325. if(NOMC.eq.IMAT1.LISPRI(lmf)
  326. & .OR.LXNM.eq.IMAT1.LISPRI(lmf))then
  327. if(LXNM.eq.IMAT1.LISPRI(lmf))NOMKP='LX'//NOMK(1:2)
  328.  
  329. if(NOMC.NE.IMAT1.LISDUA(lmf)
  330. & .AND.LXNM.NE.IMAT1.LISDUA(lmf))then
  331. write(6,*)' On a perdu ', nomc,lmf
  332. call erreur(153)
  333. return
  334. endif
  335. if(LXNM.eq.IMAT1.LISDUA(lmf))NOMKD='LX'//NOMK(1:2)
  336. NMATRI=NMATRI+1
  337. segadj MATRIK
  338. do 6434 i7=1,7
  339. irigel(i7,nmatri)=mat1.irigel(i7,lm)
  340. 6434 continue
  341.  
  342. nbme=1
  343. nbsous=IMAT1.lizafm(/1)
  344. segini IMATRI
  345. irigel(4,nmatri)=IMATRI
  346. KSPGP=IMAT1.KSPGP
  347. KSPGD=IMAT1.KSPGD
  348. LISPRI(1)=NOMKP
  349. LISDUA(1)=NOMKD
  350. do 6435 is=1,nbsous
  351. LIZAFM(is,1)=IMAT1. LIZAFM(is,lmf)
  352. 6435 continue
  353.  
  354.  
  355. endif
  356. 6433 continue
  357. 6432 continue
  358.  
  359. SEGDES MATRIK
  360. CALL ECROBJ('MATRIK',MATRIK)
  361. RETURN
  362. ENDIF
  363. C
  364. C
  365. C CAS KOP=32 'EXTRCOUP'
  366. IF(KOP.EQ.32)THEN
  367. CALL LIROBJ('MATRIK',MAT1,1,IRET)
  368. IF(IRET.EQ.0)RETURN
  369. CALL ECROBJ('MATRIK',MAT1)
  370. CALL EXTIPD
  371. CALL LIROBJ('LISTMOTS',MLMOT1,1,IRET)
  372. CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET)
  373. SEGACT MLMOT1
  374. SEGACT MLMOT2
  375. nicp=MLMOT1.MOTS(/2)
  376. nicd=MLMOT2.MOTS(/2)
  377. SEGINI STCOUP
  378. CALL INITI(MCOUP,(nicp*nicd),0)
  379. * write(6,*)(MLMOT1.MOTS(ii),ii=1,nicp)
  380. * write(6,*)(MLMOT2.MOTS(ii),ii=1,nicd)
  381.  
  382. SEGACT MAT1
  383.  
  384. NMATR1=MAT1.IRIGEL(/2)
  385. do 7432 lm=1, NMATR1
  386. IMAT1=MAT1.irigel(4,lm)
  387. segact imat1
  388. nbmf=IMAT1.LISPRI(/2)
  389.  
  390. do 7433 lmf=1,nbmf
  391. NOMKP=IMAT1.LISPRI(lmf)
  392. NOMKD=IMAT1.LISDUA(lmf)
  393. c write(6,*)NOMKP,'----',NOMKD
  394. CALL OPTLI4(IP1,MLMOT1.MOTS,NOMKP(1:4),nicp)
  395. CALL OPTLI4(IP2,MLMOT2.MOTS,NOMKD(1:4),nicd)
  396. MCOUP(IP2,IP1)=1
  397. 7433 continue
  398. 7432 continue
  399.  
  400. c write(6,*)' MCOUP ',nicp,nicd
  401. c do 7400 k=1,nicp
  402. c write(6,*)(MCOUP(k,i),i=1,nicd)
  403. c7400 continue
  404.  
  405.  
  406. IF(nicp.NE.nicd)THEN
  407. write(6,*)' ERREUR nicp ne nicd ',nicp,nicd
  408. return
  409. ENDIF
  410.  
  411.  
  412. CALL CRTABL(MTABLE)
  413. npart=0
  414.  
  415. do 7401 k=1,nicp
  416.  
  417. JGN=4
  418. JGM=0
  419. segini MLMOT3
  420. I0=MCOUP(k,k)
  421.  
  422. IF(I0.EQ.0)THEN
  423. write(6,*)' ERREUR : La diagonale est nule'
  424. return
  425. ENDIF
  426.  
  427. IF(I0.EQ.-1)GO TO 7401
  428. JGM=JGM+1
  429. SEGADJ MLMOT3
  430. MLMOT3.MOTS(JGM)=MLMOT2.MOTS(k)
  431. MCOUP(k,k)=-1
  432.  
  433. it=0
  434. do 7402 m=1,nicd
  435. I1=MCOUP(k,m)
  436. IF(I1.EQ.1)THEN
  437. it=it+1
  438. itinc(it)=i1
  439. JGM=JGM+1
  440. SEGADJ MLMOT3
  441. MLMOT3.MOTS(JGM)=MLMOT2.MOTS(m)
  442. MCOUP(k,m)=-1
  443. MCOUP(m,m)=-1
  444. ENDIF
  445. 7402 continue
  446.  
  447. 7405 continue
  448. itp=0
  449. do 7403 j=1,it
  450. il=itinc(j)
  451.  
  452. do 7403 m=1,nicd
  453. I1=MCOUP(k,m)
  454. IF(I1.EQ.1)THEN
  455. itp=itp+1
  456. itinc(itp)=i1
  457. JGM=JGM+1
  458. SEGADJ MLMOT3
  459. MLMOT3.MOTS(JGM)=MLMOT2.MOTS(m)
  460. MCOUP(il,m)=-1
  461. ENDIF
  462. 7403 continue
  463. do 7404 m=1,itp
  464. itinc(m)=itinc(m+it)
  465. 7404 continue
  466. it=itp
  467. IF(ITP.NE.0)go to 7405
  468. npart=npart+1
  469. segdes MLMOT3
  470. CALL ECCTAB(MTABLE,'ENTIER',npart,0.D0,BLAN,.TRUE.,0,
  471. 1 'LISTMOTS',0,0.D0,BLAN,.TRUE.,MLMOT3)
  472.  
  473. 7401 continue
  474.  
  475. SEGSUP STCOUP
  476. SEGDES MTABLE,MLMOT3
  477. CALL ECROBJ('TABLE',MTABLE)
  478. RETURN
  479. ENDIF
  480. C
  481. C
  482. C CAS KOP=27 'EXTRMASS' ou 'EXTRPREC'
  483. IF(KOP.EQ.27.OR.KOP.EQ.28)THEN
  484. CALL LIRCHA(NOMC,1,IRET)
  485. CALL LIRCHA(NOMK,1,IRET)
  486. IF(IRET.EQ.0)RETURN
  487. CALL LIROBJ('MATRIK',MAT1,1,IRET)
  488. IF(IRET.EQ.0)RETURN
  489.  
  490. SEGACT MAT1
  491. NRIGE =MAT1.IRIGEL(/1)
  492. NMATRI=MAT1.IRIGEL(/2)
  493. NMATRI=0
  494. NKID =MAT1.KIDMAT(/1)
  495. NKMT =MAT1.KKMMT(/1)
  496. SEGINI MATRIK
  497. CALL RSETI(KIDMAT,MAT1.KIDMAT,NKID)
  498. CALL RSETI(KKMMT ,MAT1.KKMMT ,NKMT)
  499. KSYM = MAT1.KSYM
  500. mincp= MAT1.KMINC
  501. if(mincp.ne.0)then
  502. segact mincp
  503. nbi= mincp.LISINC(/2)
  504. npt= mincp.NPOS(/1)-1
  505. segini minc
  506. call rseti(npos,mincp.npos,npt+1)
  507. call rseti(mpos,mincp.mpos,(npt*(nbi+1)))
  508. lisinc(1)=NOMK
  509. if(nbi.ne.1)then
  510. write(6,*)' Gross Pb NBI=',nbi
  511. write(6,*)(mincp.lisinc(ii),ii=1,nbi)
  512. call arret (0)
  513. endif
  514. KMINC = minc
  515. KMINCP= minc
  516. KMINCD= minc
  517. endif
  518.  
  519. KIZM = MAT1.KIZM
  520.  
  521. KISPGT= MAT1.KISPGT
  522. KISPGP= MAT1.KISPGP
  523. KISPGD= MAT1.KISPGD
  524.  
  525. KNTTT = MAT1.KNTTT
  526. KNTTP = MAT1.KNTTP
  527. KNTTD = MAT1.KNTTD
  528.  
  529. NMATR1=MAT1.IRIGEL(/2)
  530. c write(6,*)'NMATR1=',NMATR1
  531. do 6532 lm=1, NMATR1
  532. IMAT1=MAT1.irigel(4,lm)
  533. segact imat1
  534. nbmf=IMAT1.LISPRI(/2)
  535. c write(6,*)' NBMF=',nbmf
  536.  
  537. do 6533 lmf=1,nbmf
  538. if(NOMC.eq.IMAT1.LISPRI(lmf))then
  539. if(NOMC.NE.IMAT1.LISDUA(lmf))then
  540. c write(6,*)' On a perdu ', nomc,lmf
  541. call erreur(5)
  542. return
  543. endif
  544. c write(6,*)' On a gagne ', nomc,lmf
  545. NMATRI=NMATRI+1
  546. segadj MATRIK
  547. do 6534 i7=1,7
  548. irigel(i7,nmatri)=mat1.irigel(i7,lm)
  549. 6534 continue
  550.  
  551. nbme=1
  552. nbsous=IMAT1.lizafm(/1)
  553. segini IMATRI
  554. irigel(4,nmatri)=IMATRI
  555. KSPGP=IMAT1.KSPGP
  556. KSPGD=IMAT1.KSPGD
  557. LISPRI(1)=NOMK
  558. LISDUA(1)=NOMK
  559. do 6535 is=1,nbsous
  560. c? LIZAFM(is,1)=IMAT1. LIZAFM(is,lmf)
  561. 6535 continue
  562.  
  563.  
  564. endif
  565. 6533 continue
  566. 6532 continue
  567. SEGDES MATRIK
  568. CALL ECROBJ('MATRIK',MATRIK)
  569. RETURN
  570. ENDIF
  571. C
  572. * Option CHANINCO idem opérateur 'CHANGER' 'INCO'
  573. * mais pour les matrik et pour les rigidités y compris les multiplicateurs
  574. IF (KOP.EQ.29) THEN
  575. * MAtrik CHanger INco
  576. CALL MACHIN
  577. RETURN
  578. ENDIF
  579. C
  580. * Option TRANSPOS transpose une matrice
  581. * (matrik ou rigidité)
  582. IF (KOP.EQ.30) THEN
  583. * TRanSpose MaTrice
  584. CALL TRSMAT
  585. RETURN
  586. ENDIF
  587. C
  588. * Option MATIAGO pour créer une matrice diagonale
  589. IF (KOP .EQ. 31) THEN
  590. CALL KOPDIA
  591. RETURN
  592. ENDIF
  593. C
  594. GO TO 10
  595.  
  596. C ==============================================
  597. C Cas : Objet = FLOTTANT ou ENTIER
  598. C ==============================================
  599. ELSEIF(MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER')THEN
  600. NAG=NAG+1
  601. NFLOT=NFLOT+1
  602. IF(NAG.GT.2)GO TO 91
  603. IF((NAG.EQ.1).OR.(NBMAT.EQ.1)) THEN
  604. CALL LIRREE(XVAL,1,IRET)
  605. XVAL1=XVAL
  606. GO TO 10
  607. END IF
  608. IF(NAG.EQ.2)CALL LIRREE(XVAL,1,IRET)
  609. XVAL2=XVAL
  610. GO TO 10
  611.  
  612. C =============================================
  613. C Cas : Objet = CHPOINT
  614. C =============================================
  615. ELSEIF(MTYP.EQ.'CHPOINT')THEN
  616. NAG=NAG+1
  617. IF(NAG.GT.2)GO TO 91
  618. IF ((NAG.EQ.1).OR.(NBMAT.EQ.1))THEN
  619. CALL LIROBJ('CHPOINT',MCHPO1,1,IRET)
  620. CALL LICHT(MCHPO1,MPOVA1,TYPE1,IGEOM1)
  621. ELSE
  622. CALL LIROBJ('CHPOINT',MCHPO2,1,IRET)
  623. IF(KOP.NE.15)THEN
  624. CALL LICHT(MCHPO2,MPOVA2,TYPE2,IGEOM2)
  625. ELSE
  626. GO TO 20
  627. ENDIF
  628. ENDIF
  629.  
  630. C ============================================
  631. C Cas : Objet = TABLE
  632. C ============================================
  633. ELSEIF(MTYP.EQ.'TABLE'.OR.MTYP.EQ.'MMODEL')THEN
  634. NAG=NAG+1
  635. IF(NAG.GT.2)GO TO 91
  636. C? CALL LITABS('DOMAINE ',MTABD,1,1,IRET)
  637. CALL LITDMD(MMODEL,MTABD,IRET)
  638. IF(IRET.EQ.0)RETURN
  639. IF(MTABD.EQ.0)CALL LEKMOD(MMODEL,MTABD,INEFMD)
  640. C INEFMD=1 LINE =2 MACRO =3 QUADRATIQUE
  641.  
  642. C ============================================
  643. C Cas : Objet = POINT
  644. C ============================================
  645. ELSEIF(MTYP.EQ.'POINT')THEN
  646. NAG=NAG+1
  647. IF(NAG.GT.2)GO TO 91
  648. CALL LIROBJ('POINT',MPOINT,1,IRET)
  649. IF(NAG.EQ.1)IKASS=4
  650. IF(NAG.EQ.2)IKASS=5
  651. XVEC(1)=XCOOR((MPOINT-1)*(IDIM+1) +1)
  652. XVEC(2)=XCOOR((MPOINT-1)*(IDIM+1) +2)
  653. IF(IDIM.EQ.3)XVEC(3)=XCOOR((MPOINT-1)*(IDIM+1)+3)
  654. C Si MPOVA1 n'est pas initialise, il peut poser
  655. C des problemes dans la partie 'operations'
  656.  
  657. MPOVA1 = 0
  658. C ===========================================
  659. C Cas Objet = MATRIK
  660. C ===========================================
  661. ELSEIF(MTYP.EQ.'MATRIK')THEN
  662. NAG=NAG+1
  663. IF(NAG.GT.2)GO TO 91
  664. NBMAT=NBMAT+1
  665. IF (NBMAT.EQ.1) THEN
  666. CALL LIROBJ('MATRIK',MAT1,1,IRET)
  667. ELSEIF (NBMAT.EQ.2) THEN
  668. CALL LIROBJ('MATRIK',MAT2,1,IRET)
  669. END IF
  670. IF (NBMAT.EQ.1) IKASS=6
  671. IF (NBMAT.EQ.2) IKASS=7
  672.  
  673. C ===========================================
  674. C Cas Objet non prevu
  675. C ===========================================
  676. ELSE
  677. MOTERR(1:8)=MTYP
  678. CALL ERREUR(39)
  679. * WRITE(6,*)' Opérateur KOPS :'
  680. * WRITE(6,*)' Type d''objet :',MTYP,' non prevu'
  681. RETURN
  682. ENDIF
  683.  
  684.  
  685. GO TO 10
  686.  
  687. C *****************************************
  688. C * Deuxieme partie *
  689. C * On effectue ici une batterie de tests *
  690. C * afin de determiner si on fait des *
  691. C * operations valides *
  692. C *****************************************
  693. 9 CONTINUE
  694. IF (JMOTS.EQ.0) THEN
  695. moterr(1:8)='MOTS '
  696. call erreur(37)
  697. RETURN
  698. ENDIF
  699. IKAS=3
  700. IF(MCHPO1.EQ.0)IKAS=1
  701. IF(MCHPO2.EQ.0)IKAS=2
  702. IF((MCHPO1.EQ.0.AND.MCHPO2.EQ.0).AND.NBMAT.EQ.0)THEN
  703. WRITE(6,*)' Opérateur KOPS :'
  704. WRITE(6,*)' Il n''y a pas de CHPOINT ?? '
  705. RETURN
  706. ENDIF
  707. IF(IKASS.NE.0)IKAS=IKASS
  708. C write(6,*)' MCHPO1,MCHPO2=',MCHPO1,MCHPO2,IKAS,IKASS
  709. C &,' KOP=',KOP
  710.  
  711. IF(IKAS.EQ.3)THEN
  712.  
  713. IF(IGEOM1.NE.IGEOM2)THEN
  714. NBCOMP=-1
  715. CALL QUEPOI(MCHPO2,IGEOM1,INDIC,NBCOMP,NOMTOT)
  716. C write(6,*)' indic,nbcom=',indic,nbcom
  717. CALL LICHT(MCHPO2,MPOVA2,TYPE2,IGEOM2)
  718. IF(INDIC.LT.0)THEN
  719. WRITE(6,*)' Opérateur KOPS :'
  720. WRITE(6,*)' Les deux champs n''ont pas le meme support '
  721. & ,'geometrique ou pire '
  722. WRITE(6,*)' IGEOM1=',IGEOM1,' IGEOM2=',IGEOM2
  723. RETURN
  724. ENDIF
  725. ENDIF
  726.  
  727. IF(MPOVA1.EQ.0.AND.IGEOM1.EQ.0)THEN
  728. C WRITE(6,*)'CAS OU LES CHPOINTS SONT VIDE'
  729. NC1=0
  730. NC2=0
  731. NS=0
  732. ELSE
  733. NC1=MPOVA1.VPOCHA(/2)
  734. NC2=MPOVA2.VPOCHA(/2)
  735. NS =MPOVA1.VPOCHA(/1)
  736. ENDIF
  737.  
  738. NC=NC1
  739. NCK=NC
  740. IGEOM=IGEOM1
  741. TYPE=TYPE1
  742. IF(NC1.NE.NC2)THEN
  743. IF(NC1.EQ.1.AND.NC2.EQ.IDIM.AND.KOP.EQ.6)THEN
  744. NC=NC1
  745. NCK=NC2
  746. ELSE
  747. WRITE(6,*)' Opérateur KOPS :'
  748. WRITE(6,*)' Les deux champs n''ont pas le meme nombre ',
  749. & 'de composante'
  750. RETURN
  751. ENDIF
  752. ELSE
  753. IF(KOP.EQ.6)IKAS=6
  754. ENDIF
  755.  
  756.  
  757. ENDIF
  758.  
  759. IF(IKAS.EQ.1)THEN
  760. IF(MPOVA2.EQ.0.AND.IGEOM2.EQ.0)THEN
  761. C WRITE(6,*)'CAS OU LE CHPOINT2 EST VIDE'
  762. NS=0
  763. NC=0
  764. ELSE
  765. NS=MPOVA2.VPOCHA(/1)
  766. NC=MPOVA2.VPOCHA(/2)
  767. ENDIF
  768.  
  769. NC2=NC
  770. NCK=NC
  771. IGEOM=IGEOM2
  772. TYPE=TYPE2
  773.  
  774. ELSEIF(IKAS.EQ.2)THEN
  775. IF(MPOVA1.EQ.0.AND.IGEOM1.EQ.0)THEN
  776. C WRITE(6,*)'CAS OU LE CHPOINT1 EST VIDE'
  777. NS=0
  778. NC=0
  779. ELSE
  780. NS=MPOVA1.VPOCHA(/1)
  781. NC=MPOVA1.VPOCHA(/2)
  782. ENDIF
  783. NC2=NC
  784. NCK=NC
  785. IGEOM=IGEOM1
  786. TYPE=TYPE1
  787.  
  788. ELSEIF(IKAS.EQ.4)THEN
  789. NS=MPOVA2.VPOCHA(/1)
  790. NC=MPOVA2.VPOCHA(/2)
  791. IF(NC.NE.1)THEN
  792. WRITE(6,*)' Opérateur KOPS :'
  793. WRITE(6,*)' Le champoint doit etre scalaire dans ce cas '
  794. RETURN
  795. ENDIF
  796. NC2=IDIM
  797. NCK=IDIM
  798. IGEOM=IGEOM2
  799. TYPE=TYPE2
  800. ELSEIF(IKAS.EQ.5)THEN
  801. NS=MPOVA1.VPOCHA(/1)
  802. NC=MPOVA1.VPOCHA(/2)
  803. IF(NC.NE.1)THEN
  804. WRITE(6,*)' Opérateur KOPS :'
  805. WRITE(6,*)' Le champoint doit etre scalaire dans ce cas '
  806. RETURN
  807. ENDIF
  808. NC2=IDIM
  809. NCK=IDIM
  810. IGEOM=IGEOM1
  811. TYPE=TYPE1
  812. ENDIF
  813.  
  814. 20 CONTINUE
  815. IF(KOP.EQ.25)GO TO 31
  816. GO TO (21,22,23,24,25,21,22,26,27,28,29,30,31,32,33,34),KOP
  817.  
  818. C ************************************
  819. C * Dans cette partie on effectue *
  820. C * les operations *
  821. C ************************************
  822.  
  823. C MULT
  824. 21 CONTINUE
  825.  
  826. C =======================
  827. C PRODUIT 2 OBJETS MATRIK
  828. C =======================
  829. IF(NBMAT.EQ.2) THEN
  830. CALL ETOILE(MAT1,MAT2,MAT3,IRET)
  831.  
  832. IF (IRET.NE.0) THEN
  833. WRITE(6,*) 'Pb dans ETOILE'
  834. RETURN
  835. END IF
  836.  
  837. CALL ECROBJ('MATRIK',MAT3)
  838.  
  839. C =============================
  840. C PRODUIT OBJET MATRIK FLOTTANT
  841. C =============================
  842. ELSEIF ((NBMAT.EQ.1).AND.(NFLOT.EQ.1)) THEN
  843.  
  844. CALL PRDMF(XVAL1,MAT1,MAT2)
  845. CALL ECROBJ('MATRIK',MAT2)
  846.  
  847. C =============================
  848. C PRODUIT OBJET MATRIK CHPOINT
  849. C =============================
  850. ELSEIF ((NBMAT.EQ.1).AND.(MCHPO1.NE.0)) THEN
  851. CALL PRDMCP(MAT1,MCHPO1,MCHPO2)
  852. CALL ECROBJ('CHPOINT',MCHPO2)
  853. C =============================
  854.  
  855. ELSE
  856. CALL CRCHPT(TYPE,IGEOM,NCK,MCHPOI)
  857. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  858. C CB215821 : pour eviter le plantage en compilcd lorsque MPOVA1=0 ...
  859. IF (MPOVAL .NE. 0) THEN
  860. IF (MPOVA1 .EQ. 0) MPOVA1 = MPOVAL
  861. IF(IKAS.EQ.1)THEN
  862. CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1,
  863. & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  864. ELSEIF(IKAS.EQ.2)THEN
  865. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1,
  866. & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  867. ELSE
  868. C segact mchpoi
  869. C write(6,*)' segact ok avt kops1 ',kop
  870. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1,
  871. & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  872. ENDIF
  873. ENDIF
  874. C segact mchpoi
  875. C write(6,*)' segact ok apr kops1 '
  876. C write(6,*)' MCHPOI=',mchpoi
  877. CALL ECROBJ('CHPOINT ',MCHPOI)
  878. END IF
  879.  
  880. GO TO 89
  881.  
  882.  
  883. C DIVI
  884. 22 CONTINUE
  885.  
  886. CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI)
  887. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  888. C CB215821 : pour eviter le plantage en compilcd lorsque MPOVA1=0 ...
  889. IF (MPOVAL .NE. 0) THEN
  890. IF (MPOVA1 .EQ. 0) MPOVA1 = MPOVAL
  891. C write(6,*)' MCHPOI=',mchpoi,IKAS
  892. C write(6,*)' NC,NC2,NS=',NC,NC2,NS
  893. IF(IKAS.EQ.1)THEN
  894. CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1
  895. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  896. ELSEIF(IKAS.EQ.2)THEN
  897. segact mchpoi,mchpo1,mpoval,mpova1
  898. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1
  899. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  900. segact mchpoi,mchpo1,mpoval,mpova1
  901. ELSE
  902. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1
  903. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  904. ENDIF
  905. ENDIF
  906. CALL ECROBJ('CHPOINT ',MCHPOI)
  907. GO TO 89
  908.  
  909. C ........
  910. 23 CONTINUE
  911. GO TO 89
  912.  
  913. C ........
  914. 24 CONTINUE
  915. GO TO 89
  916.  
  917. C ET
  918. 25 CONTINUE
  919. WRITE(6,*)' Opérateur KOPS :'
  920. WRITE(6,*)' ET : Non operationnel pour l''instant'
  921. GO TO 89
  922.  
  923. C '+'
  924. 26 CONTINUE
  925.  
  926. IF (NBMAT.EQ.2) THEN
  927.  
  928. C On effectue l addition MAT1+MAT2 et on recupere la
  929. C matrice resultante dans MAT3 en morse
  930. CALL ADDMAT(MAT1,MAT2,MAT3,IRET)
  931.  
  932. IF (IRET.NE.0) THEN
  933. WRITE(6,*) 'Pb dans ADDMAT'
  934. RETURN
  935. END IF
  936.  
  937. CALL ECROBJ('MATRIK',MAT3)
  938. ELSE
  939. CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI)
  940. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  941. C CB215821 : pour eviter le plantage en compilcd lorsque MPOVA1=0 ...
  942. IF (MPOVAL .NE. 0) THEN
  943. IF (MPOVA1 .EQ. 0) MPOVA1 = MPOVAL
  944. IF(IKAS.EQ.1)THEN
  945. CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,
  946. & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  947. ELSEIF(IKAS.EQ.2)THEN
  948. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,
  949. & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  950. ELSE
  951. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,
  952. & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  953. ENDIF
  954. ENDIF
  955. CALL ECROBJ('CHPOINT ',MCHPOI)
  956. END IF
  957. GO TO 89
  958.  
  959. C '-'
  960. 27 CONTINUE
  961.  
  962. CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI)
  963. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  964. C CB215821 : pour eviter le plantage en compilcd lorsque MPOVA1=0 ...
  965. IF (MPOVAL .NE. 0) THEN
  966. IF (MPOVA1 .EQ. 0) MPOVA1 = MPOVAL
  967. IF(IKAS.EQ.1)THEN
  968. CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1
  969. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  970. ELSEIF(IKAS.EQ.2)THEN
  971. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1
  972. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  973. ELSE
  974. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1
  975. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  976. ENDIF
  977. ENDIF
  978. CALL ECROBJ('CHPOINT ',MCHPOI)
  979. GO TO 89
  980.  
  981. C '**'
  982. 28 CONTINUE
  983.  
  984. CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI)
  985. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  986. C CB215821 : pour eviter le plantage en compilcd lorsque MPOVA1=0 ...
  987. IF (MPOVAL .NE. 0) THEN
  988. IF (MPOVA1 .EQ. 0) MPOVA1 = MPOVAL
  989. IF(IKAS.EQ.1)THEN
  990. CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1
  991. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  992. ELSEIF(IKAS.EQ.2)THEN
  993. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1
  994. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  995. ELSE
  996. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1
  997. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  998. ENDIF
  999. ENDIF
  1000. CALL ECROBJ('CHPOINT ',MCHPOI)
  1001. GO TO 89
  1002.  
  1003. C '|<'
  1004. 29 CONTINUE
  1005.  
  1006. CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI)
  1007. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  1008. C CB215821 : pour eviter le plantage en compilcd lorsque MPOVA1=0 ...
  1009. IF (MPOVAL .NE. 0) THEN
  1010. IF (MPOVA1 .EQ. 0) MPOVA1 = MPOVAL
  1011. IF(IKAS.EQ.1)THEN
  1012. CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1
  1013. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  1014. ELSEIF(IKAS.EQ.2)THEN
  1015. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1
  1016. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  1017. ELSE
  1018. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1
  1019. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  1020. ENDIF
  1021. ENDIF
  1022. CALL ECROBJ('CHPOINT ',MCHPOI)
  1023. GO TO 89
  1024.  
  1025. C '>|'
  1026. 30 CONTINUE
  1027.  
  1028. CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI)
  1029. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  1030. C CB215821 : pour eviter le plantage en compilcd lorsque MPOVA1=0 ...
  1031. IF (MPOVAL .NE. 0) THEN
  1032. IF (MPOVA1 .EQ. 0) MPOVA1 = MPOVAL
  1033. IF(IKAS.EQ.1)THEN
  1034. CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1
  1035. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  1036. ELSEIF(IKAS.EQ.2)THEN
  1037. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1
  1038. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  1039. ELSE
  1040. CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1
  1041. $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC)
  1042. ENDIF
  1043. ENDIF
  1044. CALL ECROBJ('CHPOINT ',MCHPOI)
  1045. GO TO 89
  1046.  
  1047. C 'GRAD'
  1048. 31 CONTINUE
  1049. IF(MTABD.EQ.0)THEN
  1050. CALL ERREUR(-182)
  1051. RETURN
  1052. ENDIF
  1053. IF(KOP.EQ.25)THEN
  1054. CALL KGRAS(MCHPO1,MPOVA1,IGEOM1,MTABD)
  1055. ELSE
  1056. CALL KGRA(MCHPO1,MPOVA1,IGEOM1,MTABD)
  1057. ENDIF
  1058. GO TO 89
  1059.  
  1060. C 'ROT'
  1061. 32 CONTINUE
  1062. IF(MTABD.EQ.0)THEN
  1063. CALL ERREUR(-182)
  1064. RETURN
  1065. ENDIF
  1066. CALL KROT(MCHPO1,MPOVA1,IGEOM1,MTABD)
  1067. GO TO 89
  1068.  
  1069. C 'CLIM'
  1070. 33 CONTINUE
  1071. CALL KBOR(MCHPO1,MCHPO2)
  1072. GO TO 89
  1073.  
  1074. 89 CONTINUE
  1075. C? IF(KOP.NE.15)THEN
  1076. C? IF(MCHPOI.NE.0)SEGDES MCHPOI,MPOVAL
  1077. C? IF(MCHPO1.NE.0)SEGDES MCHPO1,MPOVA1
  1078. C? IF(MCHPO2.NE.0)SEGDES MCHPO2,MPOVA2
  1079. C? ENDIF
  1080. RETURN
  1081.  
  1082. C 'INV'
  1083. 34 CONTINUE
  1084. IF (NBMAT.EQ.1) THEN
  1085. NAG=2
  1086. CALL INVMAT(MAT1,MAT2,IRET)
  1087. CALL ECROBJ('MATRIK',MAT2)
  1088. ELSE
  1089. WRITE(6,*) 'KOPS: On ne peut inverser qu une matrice'
  1090. END IF
  1091. RETURN
  1092.  
  1093. 91 CONTINUE
  1094. WRITE(6,*)' Opérateur KOPS :'
  1095. WRITE(6,*)' Nombre d''argument superieur a 2 '
  1096. RETURN
  1097. END
  1098.  
  1099.  
  1100.  
  1101.  
  1102.  

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