C SIGSOL SOURCE FANDEUR 10/12/14 21:19:34 6812 SUBROUTINE SIGSOL C_______________________________________________________________________ C C Op{rateur contraintes lin{aires pour objet solution C C C SYNTAXE : C _________ C C SOL1 = SIGSOL MODL1 MAT1 ( CAR1 ) SOLUT ; C C MAT1 Champ de CARACTERISTIQUES ou de HOOKE (type MCHAML ) C CAR1 Champ de CARACTERISTIQUES (type MCHAML) C SOLUT OBJET solution (ne contenant pas de contraintes ) C C FEVRIER 87 BROCHARD : C - LE CALCUL EFFECTIF EST FAIT DANS SIGMAP C C Passage aux nouveaux CHAMELEMS par I.Monnier le 3.07.90 C_______________________________________________________________________ C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC CCOPTIO -INC SMCHAML -INC SMCHPOI -INC SMSOLUT * LOGICAL L0,L1 CHARACTER*8 MOMOD,MOSTA,MOPSM,CTYP,TYPRET,CHARRE CHARACTER*40 TYPBAS CHARACTER*72 CTEXT PARAMETER(XZER=0.D0,UNDEMI=.5D0,UN=1.D0) PARAMETER(IZERO=0,IUN=1) DATA MOMOD,MOSTA,MOPSM/'MODE ','SOLUSTAT','PSEUMODE'/ * * IPOI11 IRT11 OBJERT SOLUTION NE CONTENANT PAS DE * CONTRAINTES * IPOI1 IRT1 POINTEUR CHPO DEPL. OBJET SOLUTION * IPCHA1=0 IPCHA2=0 ICONV =0 IPCHE1=0 IPCHE2=0 C C LECTURE DU MODELE C CALL LIROBJ('MMODEL',IPMODL,1,IRT1) IF(IRT1.EQ.0) GOTO 666 C C LECTURE DU 1ER MCHAML C CALL LIROBJ('MCHAML',IPCHA1,1,IRT1) IF(IRT1.EQ.0) GOTO 666 C C LECTURE DU 2EME MCHAML C CALL LIROBJ('MCHAML',IPCHA2,0,IRT1) C CALL RNGCHA(IPCHA1,IPCHA2,'CARACTERISTIQUES', 1 'MATRICE DE HOOKE',IPCHE1,IPCHE2) IF (IPCHE2.EQ.0) THEN IMAT=1 ELSE IMAT=2 ENDIF * * lecture d'une TABLE ou d'un objet SOLUTION * CALL QUETYP(CTYP,IUN,IRETOU) IF (CTYP(1:8).EQ.'TABLE ') THEN CALL LIRTAB('BASE_MODALE',ITBAS,IZERO,IRET) IF (IRET.EQ.0) THEN CALL LIRTAB('ENSEMBLE_DE_BASES',ITBAS,IUN,IRET) ENDIF IF (IERR.NE.0) RETURN CALL ACCTAB(ITBAS,'MOT',I0,X0,'SOUSTYPE',L0,IP0, & 'MOT',I1,X1,TYPBAS,L1,IP1) * * Cas oš la base est unique * IF (TYPBAS(1:11).EQ.'BASE_MODALE') THEN * * On r{cup}re la base de modes * CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0, & 'TABLE',I1,X1,' ',L1,IBAS) CALL SIGTAB('MODE',IBAS,IPCHA1,IPCHE1,IPCHE2,ICONV, 1 IMAT,IPMODL) TYPRET = ' ' CALL ACCTAB(ITBAS,'MOT',I0,X0,'PSEUDO_MODES',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ITPS) IF (ITPS.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN CALL SIGTAB('PSMO',ITPS,IPCHA1,IPCHE1,IPCHE2,ICONV, 1 IMAT,IPMODL) ENDIF * * Cas oš on a un ensemble de bases * ELSE IF (TYPBAS(1:17).EQ.'ENSEMBLE_DE_BASES') THEN * * On boucle sur le nombre de bases * IB = 0 10 CONTINUE TYPRET = ' ' IB = IB + 1 CALL ACCTAB(ITBAS,'ENTIER',IB,X0,' ',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ITTBAS) IF (ITTBAS.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN CALL ACCTAB(ITTBAS,'MOT',I0,X0,'MODES',L0,IP0, & 'TABLE',I1,X1,' ',L1,IBAS) CALL SIGTAB('MODE',IBAS,IPCHA1,IPCHE1,IPCHE2,ICONV, 1 IMAT,IPMODL) TYPRET = ' ' CALL ACCTAB(ITTBAS,'MOT',I0,X0,'PSEUDO_MODES',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ITPS) IF (ITPS.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN CALL SIGTAB('PSMO',ITPS,IPCHA1,IPCHE1,IPCHE2,ICONV, 1 IMAT,IPMODL) ENDIF GOTO 10 ENDIF ENDIF CALL ECROBJ('TABLE ',ITBAS) RETURN ENDIF *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+* * version appel{e @ disparaitre *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+* CALL LIROBJ('SOLUTION',IPOI11,IUN,IRT11) IF(IRT11.EQ.0) GOTO 666 C C CALCUL DES CONTRAINTES BOUCLES SUR LES MODES C OU LES SOLUTIONS STATIQUES OU LES PSEUDO-MODES. C MSOLUT=IPOI11 SEGACT MSOLUT C C IMOD = 0 ERREUR, = 1 MODE, = 2 SOLUSTAT, = 3 PSEUMODE C IMOD=0 IF(ITYSOL.EQ.'MODE ') IMOD=1 IF(ITYSOL.EQ.'SOLUSTAT') IMOD=2 IF(ITYSOL.EQ.'PSEUMODE') IMOD=3 IF(IMOD.NE.0) GOTO 110 MOTERR(1:8)='SOLUTION' CALL ERREUR(302) GOTO 666 C 110 CONTINUE MSOLEN=MSOLIS(5) SEGACT MSOLEN N=ISOLEN(/1) SEGINI MSOLE1 DO 200 ICHO=1,N IPOI1=ISOLEN(ICHO) MCHPOI = IPOI1 SEGACT MCHPOI CTEXT = MOCHDE SEGDES MCHPOI IRT1=1 IRT8=0 IPOI6=0 IRT6=0 IRT9=0 CALL SIGMAP(0,IPMODL,IPOI1,IPCHE1,IPCHE2,ICONV,IMAT,IPOI8,IRET) IF(IRET.EQ.0) GOTO 210 MSOLE1.ISOLEN(ICHO)=IPOI8 200 CONTINUE C C CREATION DU NOUVEL OBJET SOLUTION C SEGDES MSOLE1,MSOLEN NIPO=MSOLIS(/1) IF(NIPO.LE.6) NIPO=6 SEGINI MSO1 MSO1.ITYSOL=ITYSOL C DO 201 IPO=1,NIPO MSO1.MSOLIS(IPO)=MSOLIS(IPO) MSO1.MSOLIT(IPO)=MSOLIT(IPO) 201 CONTINUE MSO1.MSOLIS(6)=MSOLE1 MSO1.MSOLIT(6)=5 SEGDES MSO1,MSOLUT C C ECRITURE DU NOUVEL OBJET SOLUTION C CALL ECROBJ('SOLUTION',MSO1) GOTO 666 C C ON N A PAS PU CREER UN CHAMELEM DE CONT. ON DETRUIT C LE NOUVEL OBJET SOLUTION 210 CONTINUE SEGSUP MSOLE1 SEGDES MSOLEN,MSOLUT C C 666 CONTINUE RETURN END