C KOPS SOURCE MAGN 13/03/21 21:15:02 7734 C Retour à la version de Stéphane C KOPS SOURCE GOUNAND 11/05/25 21:15:20 6980 SUBROUTINE KOPS C************************************************************************* C C cet operateur effectue des operations speciales entre les CHPOINT-TRIO C C C C C************************************************************************* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCOPTIO -INC SMTABLE -INC SMLMOTS -INC SMLENTI -INC SMELEME POINTEUR MELEMC.MELEME -INC SMCOORD -INC SMMATRIK POINTEUR MAT1.MATRIK,MAT2.MATRIK,MAT3.MATRIK,IMAT1.IMATRI * -INC SMRIGID * * OBJET RIGIDITE * SEGMENT STCOUP INTEGER MCOUP(nicd,nicp) ENDSEGMENT SEGMENT MRIGID CHARACTER*8 MTYMAT REAL*8 COERIG(NRIGEL) INTEGER JRIGEL(8,NRIGEL) INTEGER ICHOLE,IMGEO1,IMGEO2,IFORIG INTEGER ISUPEQ,JRCOND,JRDEPP,JRDEPD INTEGER JRELIM,JRGARD,JRTOT,IMLAG INTEGER IPROFO,IVECRI ENDSEGMENT -INC SMCHPOI C POINTEUR IZV1.MCHPOI,IZVV1.MPOVAL C POINTEUR IZV2.MCHPOI,IZVV2.MPOVAL DIMENSION XVEC(3),ITINC(100) INTEGER JMOTS CHARACTER*8 TYPE,TYPC,TYPE1,TYPE2 PARAMETER (NBOP=32) CHARACTER*4 MOT4,NOMTOT(10) CHARACTER*8 LOPER(NBOP),MTYP,NOMI,NOM,NOMC,NOMK,LXNM CHARACTER*8 NOMKP,NOMKD CHARACTER*8 BLAN DATA BLAN/' '/ DATA LOPER/'MULT ','DIVI ','PSRN ','PSCA ','ET ', & '* ','/ ','+ ','- ','** ', & '|< ','>| ','GRAD ','ROT ','CLIM ', & 'INV ','MATRAK ','MATRIK ','VNIMP ','VTIMP ', & 'MTABX ','CMCTSPLT','MATIDE ','RIGIDITE','GRADS ', & 'EXTRCOMP','EXTRMASS','EXTRPREC','CHANINCO','TRANSPOS', & 'MATDIAGO','EXTRCOUP'/ C*** JMOTS=0 NAG=0 NBMAT=0 IKASS=0 MCHPO1=0 MCHPO2=0 MCHPOI=0 XVAL1=0.D0 XVAL2=0.D0 NFLOT=0 MTABD=0 C ******************************************** C * La premiere partie de cette routine * C * consiste a recuperer les arguments de * C * l operateur KOPS afin de pouvoir leurs * C * attribuer le traitement correspondant * C ******************************************** 10 CONTINUE C On saisit le premier objet de la pile C ************************************* CALL QUETYP(MTYP,0,IRET) IF(IRET.EQ.0)GO TO 9 C write(6,*)' KOPS nag=',NAG,' MTYP=',MTYP C ============================================ C Cas : Objet = MOT C ============================================ IF(MTYP.EQ.'MOT')THEN JMOTS=1 C? CALL LIRCHA(MMOP,1,NBC) C? CALL OPTLI(KOP,LOPER,MMOP,NBOP) CALL LIRMOT(LOPER,NBOP,KOP,0) C write(6,*)' KOPS ',LOPER(KOP) IF(KOP.EQ.0)THEN CALL RYO2V(IRET) IF(IRET.EQ.0)RETURN WRITE(6,*)' Opérateur KOPS :',KOP WRITE(6,*)' Operation inconnue ' RETURN ENDIF C Cas tres tres particulier(s) C CAS KOP=17 IF(KOP.EQ.17)THEN NRIGE=8 NMATRI=0 NKID =9 NKMT =7 SEGINI MATRIK SEGDES MATRIK CALL ECROBJ('MATRIK',MATRIK) RETURN ENDIF C CAS KOP=18 IF(KOP.EQ.18)THEN NRIGE=7 NMATRI=0 NKID =9 NKMT =7 SEGINI MATRIK SEGDES MATRIK CALL ECROBJ('MATRIK',MATRIK) NAT=2 NSOUPO=0 SEGINI MCHPOI JATTRI(1)=2 IFOPOI = IFOUR SEGDES MCHPOI CALL ECROBJ('CHPOINT',MCHPOI) RETURN ENDIF C CAS KOP=19 IF(KOP.EQ.19)THEN CALL VNIMP RETURN ENDIF C CAS KOP=20 IF(KOP.EQ.20)THEN CALL VTIMP RETURN ENDIF C CAS KOP=21 MTABX IF(KOP.EQ.21)THEN CALL LIROBJ('TABLE',MTABX,1,IRET) IF(IRET.EQ.0)RETURN CALL LIRREE(DTR,1,IRET) IF(IRET.EQ.0)RETURN KKIZG=0 TYPE=' ' CALL ACMO(MTABX,'KIZG',TYPE,KIZG) IF(KIZG.NE.0)THEN TYPE=' ' CALL ACMO(MTABX,'LISTINCO',TYPE,MLMOTS) IF(MLMOTS.EQ.0)RETURN SEGACT MLMOTS NBMOT=MOTS(/2) DO 36476 I=1,NBMOT NOMI=MOTS(I) TYPE=' ' CALL ACMO(KIZG,NOMI,TYPE,MCHPOI) IF(TYPE.NE.'CHPOINT')GO TO 36476 SEGACT MCHPOI NSOUPO=IPCHP(/1) IF(NSOUPO.NE.1)RETURN MSOUPO=IPCHP(1) SEGACT MSOUPO NC=NOCOMP(/2) DO 36477 J=1,NC IF(NC.NE.1.AND.NC.LT.10)THEN WRITE(MOT4,FMT='(I1,A3)')J,NOMI(1:3) ELSEIF(NC.EQ.1)THEN WRITE(MOT4,FMT='(A4)')NOMI ELSE RETURN ENDIF NOCOMP(J)=MOT4 36477 CONTINUE KKIZG=1 CALL ECROBJ('CHPOINT ',MCHPOI) CALL ECRREE(-1.D0) CALL OPERMU IF(I.GT.1)CALL OPERAD 36476 CONTINUE ENDIF IF(KKIZG.NE.0)THEN CALL ECRREE(DTR) CALL OPERMU ENDIF TYPE=' ' CALL ACMO(MTABX,'SMBR',TYPE,MCHPOI) IF(TYPE.EQ.'CHPOINT')THEN CALL ECROBJ('CHPOINT ',MCHPOI) IF(KKIZG.NE.0)CALL OPERAD ELSE IF(KKIZG.EQ.0)CALL ECRREE(1.D0) ENDIF CALL ECME(MTABX,'SMBR',1) RETURN ENDIF C CAS KOP=22 IF(KOP.EQ.22)THEN CALL SPLTCC RETURN ENDIF C KAS KOP=23 ('MATIDE') IF(KOP .EQ. 23)THEN CALL KOPSID RETURN ENDIF C CAS KOP=24 IF(KOP.EQ.24)THEN NRIGE=8 NRIGEL=0 SEGINI MRIGID SEGDES MRIGID CALL ECROBJ('RIGIDITE',MRIGID) NAT=2 NSOUPO=0 SEGINI MCHPOI JATTRI(1)=2 IFOPOI = IFOUR SEGDES MCHPOI CALL ECROBJ('CHPOINT',MCHPOI) RETURN ENDIF C C CAS KOP=25 'GRADS' IF(KOP.EQ.25)THEN GO TO 10 ENDIF C C CAS KOP=26 'EXTRCOMP' IF(KOP.EQ.26)THEN CALL LIRCHA(NOMC,1,IRET) CALL LIRCHA(NOMK,1,IRET) IF(IRET.EQ.0)RETURN CALL LIROBJ('MATRIK',MAT1,1,IRET) IF(IRET.EQ.0)RETURN SEGACT MAT1 NRIGE =MAT1.IRIGEL(/1) NMATRI=MAT1.IRIGEL(/2) NMATRI=0 NKID =MAT1.KIDMAT(/1) NKMT =MAT1.KKMMT(/1) SEGINI MATRIK CALL RSETI(KIDMAT,MAT1.KIDMAT,NKID) CALL RSETI(KKMMT ,MAT1.KKMMT ,NKMT) KSYM = MAT1.KSYM mincp= MAT1.KMINC if(mincp.ne.0)then segact mincp nbi= mincp.LISINC(/2) npt= mincp.NPOS(/1)-1 segini minc call rseti(npos,mincp.npos,npt+1) call rseti(mpos,mincp.mpos,(npt*(nbi+1))) lisinc(1)=NOMK if(nbi.ne.1)then write(6,*)' Gross Pb NBI=',nbi write(6,*)(mincp.lisinc(ii),ii=1,nbi) call arret (0) endif KMINC = minc KMINCP= minc KMINCD= minc endif KIZM = MAT1.KIZM KISPGT= MAT1.KISPGT KISPGP= MAT1.KISPGP KISPGD= MAT1.KISPGD KNTTT = MAT1.KNTTT KNTTP = MAT1.KNTTP KNTTD = MAT1.KNTTD NMATR1=MAT1.IRIGEL(/2) c write(6,*)'NMATR1=',NMATR1 do 6432 lm=1, NMATR1 IMAT1=MAT1.irigel(4,lm) segact imat1 nbmf=IMAT1.LISPRI(/2) c write(6,*)' NBMF=',nbmf LXNM='LX'//NOMC(1:2) do 6433 lmf=1,nbmf NOMKP=NOMK NOMKD=NOMK if(NOMC.eq.IMAT1.LISPRI(lmf) & .OR.LXNM.eq.IMAT1.LISPRI(lmf))then if(LXNM.eq.IMAT1.LISPRI(lmf))NOMKP='LX'//NOMK(1:2) if(NOMC.NE.IMAT1.LISDUA(lmf) & .AND.LXNM.NE.IMAT1.LISDUA(lmf))then write(6,*)' On a perdu ', nomc,lmf call erreur(153) return endif if(LXNM.eq.IMAT1.LISDUA(lmf))NOMKD='LX'//NOMK(1:2) NMATRI=NMATRI+1 segadj MATRIK do 6434 i7=1,7 irigel(i7,nmatri)=mat1.irigel(i7,lm) 6434 continue nbme=1 nbsous=IMAT1.lizafm(/1) segini IMATRI irigel(4,nmatri)=IMATRI KSPGP=IMAT1.KSPGP KSPGD=IMAT1.KSPGD LISPRI(1)=NOMKP LISDUA(1)=NOMKD do 6435 is=1,nbsous LIZAFM(is,1)=IMAT1. LIZAFM(is,lmf) 6435 continue endif 6433 continue 6432 continue SEGDES MATRIK CALL ECROBJ('MATRIK',MATRIK) RETURN ENDIF C C C CAS KOP=32 'EXTRCOUP' IF(KOP.EQ.32)THEN CALL LIROBJ('MATRIK',MAT1,1,IRET) IF(IRET.EQ.0)RETURN CALL ECROBJ('MATRIK',MAT1) CALL EXTIPD CALL LIROBJ('LISTMOTS',MLMOT1,1,IRET) CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET) SEGACT MLMOT1 SEGACT MLMOT2 nicp=MLMOT1.MOTS(/2) nicd=MLMOT2.MOTS(/2) SEGINI STCOUP CALL INITI(MCOUP,(nicp*nicd),0) * write(6,*)(MLMOT1.MOTS(ii),ii=1,nicp) * write(6,*)(MLMOT2.MOTS(ii),ii=1,nicd) SEGACT MAT1 NMATR1=MAT1.IRIGEL(/2) do 7432 lm=1, NMATR1 IMAT1=MAT1.irigel(4,lm) segact imat1 nbmf=IMAT1.LISPRI(/2) do 7433 lmf=1,nbmf NOMKP=IMAT1.LISPRI(lmf) NOMKD=IMAT1.LISDUA(lmf) c write(6,*)NOMKP,'----',NOMKD CALL OPTLI4(IP1,MLMOT1.MOTS,NOMKP(1:4),nicp) CALL OPTLI4(IP2,MLMOT2.MOTS,NOMKD(1:4),nicd) MCOUP(IP2,IP1)=1 7433 continue 7432 continue c write(6,*)' MCOUP ',nicp,nicd c do 7400 k=1,nicp c write(6,*)(MCOUP(k,i),i=1,nicd) c7400 continue IF(nicp.NE.nicd)THEN write(6,*)' ERREUR nicp ne nicd ',nicp,nicd return ENDIF CALL CRTABL(MTABLE) npart=0 do 7401 k=1,nicp JGN=4 JGM=0 segini MLMOT3 I0=MCOUP(k,k) IF(I0.EQ.0)THEN write(6,*)' ERREUR : La diagonale est nule' return ENDIF IF(I0.EQ.-1)GO TO 7401 JGM=JGM+1 SEGADJ MLMOT3 MLMOT3.MOTS(JGM)=MLMOT2.MOTS(k) MCOUP(k,k)=-1 it=0 do 7402 m=1,nicd I1=MCOUP(k,m) IF(I1.EQ.1)THEN it=it+1 itinc(it)=i1 JGM=JGM+1 SEGADJ MLMOT3 MLMOT3.MOTS(JGM)=MLMOT2.MOTS(m) MCOUP(k,m)=-1 MCOUP(m,m)=-1 ENDIF 7402 continue 7405 continue itp=0 do 7403 j=1,it il=itinc(j) do 7403 m=1,nicd I1=MCOUP(k,m) IF(I1.EQ.1)THEN itp=itp+1 itinc(itp)=i1 JGM=JGM+1 SEGADJ MLMOT3 MLMOT3.MOTS(JGM)=MLMOT2.MOTS(m) MCOUP(il,m)=-1 ENDIF 7403 continue do 7404 m=1,itp itinc(m)=itinc(m+it) 7404 continue it=itp IF(ITP.NE.0)go to 7405 npart=npart+1 segdes MLMOT3 CALL ECCTAB(MTABLE,'ENTIER',npart,0.D0,BLAN,.TRUE.,0, 1 'LISTMOTS',0,0.D0,BLAN,.TRUE.,MLMOT3) 7401 continue SEGSUP STCOUP SEGDES MTABLE,MLMOT3 CALL ECROBJ('TABLE',MTABLE) RETURN ENDIF C C C CAS KOP=27 'EXTRMASS' ou 'EXTRPREC' IF(KOP.EQ.27.OR.KOP.EQ.28)THEN CALL LIRCHA(NOMC,1,IRET) CALL LIRCHA(NOMK,1,IRET) IF(IRET.EQ.0)RETURN CALL LIROBJ('MATRIK',MAT1,1,IRET) IF(IRET.EQ.0)RETURN SEGACT MAT1 NRIGE =MAT1.IRIGEL(/1) NMATRI=MAT1.IRIGEL(/2) NMATRI=0 NKID =MAT1.KIDMAT(/1) NKMT =MAT1.KKMMT(/1) SEGINI MATRIK CALL RSETI(KIDMAT,MAT1.KIDMAT,NKID) CALL RSETI(KKMMT ,MAT1.KKMMT ,NKMT) KSYM = MAT1.KSYM mincp= MAT1.KMINC if(mincp.ne.0)then segact mincp nbi= mincp.LISINC(/2) npt= mincp.NPOS(/1)-1 segini minc call rseti(npos,mincp.npos,npt+1) call rseti(mpos,mincp.mpos,(npt*(nbi+1))) lisinc(1)=NOMK if(nbi.ne.1)then write(6,*)' Gross Pb NBI=',nbi write(6,*)(mincp.lisinc(ii),ii=1,nbi) call arret (0) endif KMINC = minc KMINCP= minc KMINCD= minc endif KIZM = MAT1.KIZM KISPGT= MAT1.KISPGT KISPGP= MAT1.KISPGP KISPGD= MAT1.KISPGD KNTTT = MAT1.KNTTT KNTTP = MAT1.KNTTP KNTTD = MAT1.KNTTD NMATR1=MAT1.IRIGEL(/2) c write(6,*)'NMATR1=',NMATR1 do 6532 lm=1, NMATR1 IMAT1=MAT1.irigel(4,lm) segact imat1 nbmf=IMAT1.LISPRI(/2) c write(6,*)' NBMF=',nbmf do 6533 lmf=1,nbmf if(NOMC.eq.IMAT1.LISPRI(lmf))then if(NOMC.NE.IMAT1.LISDUA(lmf))then c write(6,*)' On a perdu ', nomc,lmf call erreur(5) return endif c write(6,*)' On a gagne ', nomc,lmf NMATRI=NMATRI+1 segadj MATRIK do 6534 i7=1,7 irigel(i7,nmatri)=mat1.irigel(i7,lm) 6534 continue nbme=1 nbsous=IMAT1.lizafm(/1) segini IMATRI irigel(4,nmatri)=IMATRI KSPGP=IMAT1.KSPGP KSPGD=IMAT1.KSPGD LISPRI(1)=NOMK LISDUA(1)=NOMK do 6535 is=1,nbsous c? LIZAFM(is,1)=IMAT1. LIZAFM(is,lmf) 6535 continue endif 6533 continue 6532 continue SEGDES MATRIK CALL ECROBJ('MATRIK',MATRIK) RETURN ENDIF C * Option CHANINCO idem opérateur 'CHANGER' 'INCO' * mais pour les matrik et pour les rigidités y compris les multiplicateurs IF (KOP.EQ.29) THEN * MAtrik CHanger INco CALL MACHIN RETURN ENDIF C * Option TRANSPOS transpose une matrice * (matrik ou rigidité) IF (KOP.EQ.30) THEN * TRanSpose MaTrice CALL TRSMAT RETURN ENDIF C * Option MATIAGO pour créer une matrice diagonale IF (KOP .EQ. 31) THEN CALL KOPDIA RETURN ENDIF C GO TO 10 C ============================================== C Cas : Objet = FLOTTANT ou ENTIER C ============================================== ELSEIF(MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER')THEN NAG=NAG+1 NFLOT=NFLOT+1 IF(NAG.GT.2)GO TO 91 IF((NAG.EQ.1).OR.(NBMAT.EQ.1)) THEN CALL LIRREE(XVAL,1,IRET) XVAL1=XVAL GO TO 10 END IF IF(NAG.EQ.2)CALL LIRREE(XVAL,1,IRET) XVAL2=XVAL GO TO 10 C ============================================= C Cas : Objet = CHPOINT C ============================================= ELSEIF(MTYP.EQ.'CHPOINT')THEN NAG=NAG+1 IF(NAG.GT.2)GO TO 91 IF ((NAG.EQ.1).OR.(NBMAT.EQ.1))THEN CALL LIROBJ('CHPOINT',MCHPO1,1,IRET) CALL LICHT(MCHPO1,MPOVA1,TYPE1,IGEOM1) ELSE CALL LIROBJ('CHPOINT',MCHPO2,1,IRET) IF(KOP.NE.15)THEN CALL LICHT(MCHPO2,MPOVA2,TYPE2,IGEOM2) ELSE GO TO 20 ENDIF ENDIF C ============================================ C Cas : Objet = TABLE C ============================================ ELSEIF(MTYP.EQ.'TABLE'.OR.MTYP.EQ.'MMODEL')THEN NAG=NAG+1 IF(NAG.GT.2)GO TO 91 C? CALL LITABS('DOMAINE ',MTABD,1,1,IRET) CALL LITDMD(MMODEL,MTABD,IRET) IF(IRET.EQ.0)RETURN IF(MTABD.EQ.0)CALL LEKMOD(MMODEL,MTABD,INEFMD) C INEFMD=1 LINE =2 MACRO =3 QUADRATIQUE C ============================================ C Cas : Objet = POINT C ============================================ ELSEIF(MTYP.EQ.'POINT')THEN NAG=NAG+1 IF(NAG.GT.2)GO TO 91 CALL LIROBJ('POINT',MPOINT,1,IRET) IF(NAG.EQ.1)IKASS=4 IF(NAG.EQ.2)IKASS=5 XVEC(1)=XCOOR((MPOINT-1)*(IDIM+1) +1) XVEC(2)=XCOOR((MPOINT-1)*(IDIM+1) +2) IF(IDIM.EQ.3)XVEC(3)=XCOOR((MPOINT-1)*(IDIM+1)+3) C Si MPOVA1 n'est pas initialise, il peut poser C des problemes dans la partie 'operations' MPOVA1 = 0 C =========================================== C Cas Objet = MATRIK C =========================================== ELSEIF(MTYP.EQ.'MATRIK')THEN NAG=NAG+1 IF(NAG.GT.2)GO TO 91 NBMAT=NBMAT+1 IF (NBMAT.EQ.1) THEN CALL LIROBJ('MATRIK',MAT1,1,IRET) ELSEIF (NBMAT.EQ.2) THEN CALL LIROBJ('MATRIK',MAT2,1,IRET) END IF IF (NBMAT.EQ.1) IKASS=6 IF (NBMAT.EQ.2) IKASS=7 C =========================================== C Cas Objet non prevu C =========================================== ELSE MOTERR(1:8)=MTYP CALL ERREUR(39) * WRITE(6,*)' Opérateur KOPS :' * WRITE(6,*)' Type d''objet :',MTYP,' non prevu' RETURN ENDIF GO TO 10 C ***************************************** C * Deuxieme partie * C * On effectue ici une batterie de tests * C * afin de determiner si on fait des * C * operations valides * C ***************************************** 9 CONTINUE IF (JMOTS.EQ.0) THEN moterr(1:8)='MOTS ' call erreur(37) RETURN ENDIF IKAS=3 IF(MCHPO1.EQ.0)IKAS=1 IF(MCHPO2.EQ.0)IKAS=2 IF((MCHPO1.EQ.0.AND.MCHPO2.EQ.0).AND.NBMAT.EQ.0)THEN WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' Il n''y a pas de CHPOINT ?? ' RETURN ENDIF IF(IKASS.NE.0)IKAS=IKASS C write(6,*)' MCHPO1,MCHPO2=',MCHPO1,MCHPO2,IKAS,IKASS C &,' KOP=',KOP IF(IKAS.EQ.3)THEN IF(IGEOM1.NE.IGEOM2)THEN INDIC=1 NBCOMP=-1 CALL QUEPOI(MCHPO2,IGEOM1,INDIC,NBCOMP,NOMTOT) C write(6,*)' indic,nbcom=',indic,nbcom CALL LICHT(MCHPO2,MPOVA2,TYPE2,IGEOM2) IF(INDIC.LT.0)THEN WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' Les deux champs n''ont pas le meme support ' & ,'geometrique ou pire ' WRITE(6,*)' IGEOM1=',IGEOM1,' IGEOM2=',IGEOM2 RETURN ENDIF ENDIF IF(MPOVA1.EQ.0.AND.IGEOM1.EQ.0)THEN C WRITE(6,*)'CAS OU LES CHPOINTS SONT VIDE' NC1=0 NC2=0 NS=0 ELSE NC1=MPOVA1.VPOCHA(/2) NC2=MPOVA2.VPOCHA(/2) NS=MPOVA1.VPOCHA(/1) ENDIF NC=NC1 NCK=NC IGEOM=IGEOM1 TYPE=TYPE1 IF(NC1.NE.NC2)THEN IF(NC1.EQ.1.AND.NC2.EQ.IDIM.AND.KOP.EQ.6)THEN NC=NC1 NCK=NC2 ELSE WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' Les deux champs n''ont pas le meme nombre ', & 'de composante' RETURN ENDIF ELSE IF(KOP.EQ.6)IKAS=6 ENDIF ENDIF IF(IKAS.EQ.1)THEN IF(MPOVA2.EQ.0.AND.IGEOM2.EQ.0)THEN C WRITE(6,*)'CAS OU LE CHPOINT2 EST VIDE' NS=0 NC=0 ELSE NS=MPOVA2.VPOCHA(/1) NC=MPOVA2.VPOCHA(/2) ENDIF NC2=NC NCK=NC IGEOM=IGEOM2 TYPE=TYPE2 ELSEIF(IKAS.EQ.2)THEN IF(MPOVA1.EQ.0.AND.IGEOM1.EQ.0)THEN C WRITE(6,*)'CAS OU LE CHPOINT1 EST VIDE' NS=0 NC=0 ELSE NS=MPOVA1.VPOCHA(/1) NC=MPOVA1.VPOCHA(/2) ENDIF NC2=NC NCK=NC IGEOM=IGEOM1 TYPE=TYPE1 ELSEIF(IKAS.EQ.4)THEN NS=MPOVA2.VPOCHA(/1) NC=MPOVA2.VPOCHA(/2) IF(NC.NE.1)THEN WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' Le champoint doit etre scalaire dans ce cas ' RETURN ENDIF NC2=IDIM NCK=IDIM IGEOM=IGEOM2 TYPE=TYPE2 ELSEIF(IKAS.EQ.5)THEN NS=MPOVA1.VPOCHA(/1) NC=MPOVA1.VPOCHA(/2) IF(NC.NE.1)THEN WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' Le champoint doit etre scalaire dans ce cas ' RETURN ENDIF NC2=IDIM NCK=IDIM IGEOM=IGEOM1 TYPE=TYPE1 ENDIF 20 CONTINUE IF(KOP.EQ.25)GO TO 31 GO TO (21,22,23,24,25,21,22,26,27,28,29,30,31,32,33,34),KOP C ************************************ C * Dans cette partie on effectue * C * les operations * C ************************************ C MULT 21 CONTINUE C ======================= C PRODUIT 2 OBJETS MATRIK C ======================= IF(NBMAT.EQ.2) THEN CALL ETOILE(MAT1,MAT2,MAT3,IRET) IF (IRET.NE.0) THEN WRITE(6,*) 'Pb dans ETOILE' RETURN END IF CALL ECROBJ('MATRIK',MAT3) C ============================= C PRODUIT OBJET MATRIK FLOTTANT C ============================= ELSEIF ((NBMAT.EQ.1).AND.(NFLOT.EQ.1)) THEN CALL PRDMF(XVAL1,MAT1,MAT2) CALL ECROBJ('MATRIK',MAT2) C ============================= C PRODUIT OBJET MATRIK CHPOINT C ============================= ELSEIF ((NBMAT.EQ.1).AND.(MCHPO1.NE.0)) THEN CALL PRDMCP(MAT1,MCHPO1,MCHPO2) CALL ECROBJ('CHPOINT',MCHPO2) C ============================= ELSE CALL CRCHPT(TYPE,IGEOM,NCK,MCHPOI) CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) IF(IKAS.EQ.1)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1, & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSEIF(IKAS.EQ.2)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1, & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSE C segact mchpoi C write(6,*)' segact ok avt kops1 ',kop CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1, & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ENDIF C segact mchpoi C write(6,*)' segact ok apr kops1 ' C write(6,*)' MCHPOI=',mchpoi CALL ECROBJ('CHPOINT ',MCHPOI) END IF GO TO 89 C DIVI 22 CONTINUE CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) C write(6,*)' MCHPOI=',mchpoi,IKAS C write(6,*)' NC,NC2,NS=',NC,NC2,NS IF(IKAS.EQ.1)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSEIF(IKAS.EQ.2)THEN segact mchpoi,mchpo1,mpoval,mpova1 CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) segact mchpoi,mchpo1,mpoval,mpova1 ELSE CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ENDIF CALL ECROBJ('CHPOINT ',MCHPOI) GO TO 89 C PSRN 23 CONTINUE IF(IKAS.NE.3)THEN WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' Dans ce cas on attend deux CHPOINT' RETURN ENDIF N=NS*NC XVAL=SDOT(N,MPOVA1.VPOCHA(1,1),1,MPOVA2.VPOCHA(1,1),1) CALL ECRREE(XVAL) GO TO 89 C PSCA 24 CONTINUE CALL CRCHPT(TYPE,IGEOM,1,MCHPOI) CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) IF(IKAS.NE.3)THEN WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' Dans ce cas on attend deux CHPOINT' RETURN ENDIF CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1,XVAL2, & NC,NC2,NS,IKAS,KOP,XVEC) CALL ECROBJ('CHPOINT ',MCHPOI) GO TO 89 C ET 25 CONTINUE WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' ET : Non operationnel pour l''instant' GO TO 89 C '+' 26 CONTINUE IF (NBMAT.EQ.2) THEN C On effectue l addition MAT1+MAT2 et on recupere la C matrice resultante dans MAT3 en morse CALL ADDMAT(MAT1,MAT2,MAT3,IRET) IF (IRET.NE.0) THEN WRITE(6,*) 'Pb dans ADDMAT' RETURN END IF CALL ECROBJ('MATRIK',MAT3) ELSE CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) IF(IKAS.EQ.1)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA, & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSEIF(IKAS.EQ.2)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA, & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSE CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA, & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ENDIF CALL ECROBJ('CHPOINT ',MCHPOI) END IF GO TO 89 C '-' 27 CONTINUE CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) IF(IKAS.EQ.1)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSEIF(IKAS.EQ.2)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSE CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ENDIF CALL ECROBJ('CHPOINT ',MCHPOI) GO TO 89 C '**' 28 CONTINUE CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) IF(IKAS.EQ.1)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSEIF(IKAS.EQ.2)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSE CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ENDIF CALL ECROBJ('CHPOINT ',MCHPOI) GO TO 89 C '|<' 29 CONTINUE CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) IF(IKAS.EQ.1)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSEIF(IKAS.EQ.2)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSE CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ENDIF CALL ECROBJ('CHPOINT ',MCHPOI) GO TO 89 C '>|' 30 CONTINUE CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) IF(IKAS.EQ.1)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSEIF(IKAS.EQ.2)THEN CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ELSE CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) ENDIF CALL ECROBJ('CHPOINT ',MCHPOI) GO TO 89 C 'GRAD' 31 CONTINUE IF(MTABD.EQ.0)THEN CALL ERREUR(-182) RETURN ENDIF IF(KOP.EQ.25)THEN CALL KGRAS(MCHPO1,MPOVA1,IGEOM1,MTABD) ELSE CALL KGRA(MCHPO1,MPOVA1,IGEOM1,MTABD) ENDIF GO TO 89 C 'ROT' 32 CONTINUE IF(MTABD.EQ.0)THEN CALL ERREUR(-182) RETURN ENDIF CALL KROT(MCHPO1,MPOVA1,IGEOM1,MTABD) GO TO 89 C 'CLIM' 33 CONTINUE CALL KBOR(MCHPO1,MCHPO2) GO TO 89 89 CONTINUE C? IF(KOP.NE.15)THEN C? IF(MCHPOI.NE.0)SEGDES MCHPOI,MPOVAL C? IF(MCHPO1.NE.0)SEGDES MCHPO1,MPOVA1 C? IF(MCHPO2.NE.0)SEGDES MCHPO2,MPOVA2 C? ENDIF RETURN C 'INV' 34 CONTINUE IF (NBMAT.EQ.1) THEN NAG=2 CALL INVMAT(MAT1,MAT2,IRET) CALL ECROBJ('MATRIK',MAT2) ELSE WRITE(6,*) 'KOPS: On ne peut inverser qu une matrice' END IF RETURN 91 CONTINUE WRITE(6,*)' Opérateur KOPS :' WRITE(6,*)' Nombre d''argument superieur a 2 ' RETURN END