Télécharger kops.eso

Retour à la liste

Numérotation des lignes :

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

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