C LSIGMP SOURCE FANDEUR 13/01/29 21:15:59 7683 SUBROUTINE LSIGMP(IMD,IPCHE1,IPCHE2,IPCHE3,IMAT, & IPCHE4,IRET,IPM,IPNS,IPCHE) C=======================================================================C C C C ENTREES: C C C C IPCHE1 Pointeur sur un MCHAML (PRECONTAINTES ET FORCES) C C IMD NOMBRE TOTAL DE CABLES C C C C SORTIES: C C C C IPCHE4 Pointeur sur un CHPOINT de forces aux noeuds C C IRET=1 OU 0 suivant succes ou pas (Message d'erreur) C C C C C C-----------------------------------------------------------------------C C JIANG modifié FLEURET 05/96 + JMB 10/97 C C=======================================================================C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE DIMENSION IPM(*),IVASSS(100) C SEGMENT IPNN INTEGER IPNNUM(NSOU1) ENDSEGMENT C SEGMENT NNUM INTEGER NNM(NBN,NBELE),NBEM(2,NBELE) ENDSEGMENT POINTEUR INN1.NNUM SEGMENT ICCOUN INTEGER INCOR(NBELEM) ENDSEGMENT C SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT C SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT C C SEGMENT WRK4 C REAL*8 XEC(3,NBN) C ENDSEGMENT C PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM LOGICAL lsupfo C C --- CREATION D UNE VARIABLE UTILISEE LORS DE LA DESTRUCTION D UN C CHAMP POINT C CHARACTER*4 LAGEOM LAGEOM='GEOM' C IPNN=IPNS SEGACT IPNN C C --- CABLES MERIDIENS C IPMODB=IPM(1) LIYW=IMD DO 99999 IMMD=2,LIYW IPMODC=IPM(IMMD) C C --- Verification du lieu support du MCHAML de contraintes C CALL QUESUP(IPMODC,IPCHE1,3,0,ISUP1,IRET1) IF (ISUP1.GT.1) THEN IRET=0 RETURN ENDIF C======================================================================= C = C ACTIVATION DU MODELE (CABLE PRECONTRAINT: IMMD) = C = C======================================================================= MMODEL=IPMODC SEGACT MMODEL NSOU1=KMODEL(/1) DO 40 ISOU1=1,NSOU1 IF(ISOU1.GT.1) THEN MMODEL = IPM(IMMD) SEGACT MMODEL END IF C C --- ACTIVATION DES CONTRAINTES C IRET=1 MCHEL1=IPCHE1 SEGACT MCHEL1 C C --- BOUCLE SUR LES SOUS ZONES C C --- INITIALISATION C IVAMAT=0 IVACAR=0 IVASTR=0 IVAFOR=0 NMATR=0 NMATF=0 NCARA=0 NCARF=0 NSTR=0 NFORC=0 MOMATR=0 MOCARA=0 C C --- TRAITEMENT DU MODELE C IMODEL=KMODEL(ISOU1) SEGACT IMODEL MELE=NEFMOD MELEM=MELE IPMAIL=IMAMOD CONM =CONMOD NFOR=FORMOD(/2) NMAT=MATMOD(/2) C C --- ACTIVATION DU MELEME C MELEME=IPMAIL SEGACT MELEME NBNN=NUM(/1) NBELEM=NUM(/2) NNUM=IPNNUM(ISOU1) segact NNUM C C --- CREATION DU TABLEAU INFOS C CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) THEN SEGDES IMODEL,MMODEL SEGDES MCHEL1 IRET=0 RETURN ENDIF C C --- INFORMATIONS SUR L'ELEMENT FINI C NBPGAC= INFELE(4) NBG = INFELE(6) * MINTE = INFELE(11) minte=infmod(5) MINTE1= INFMOD(8) IPMINT= MINTE IPMITC= INFELE(11) IPMIN1= MINTE1 MFR = INFELE(13) NSTRS = INFELE(16) LW = INFELE(7) NDDL = INFELE(15) LIXW=1 C======================================================================= C = C ACTIVATION DU MODELE (BETON) = C = C======================================================================= MMODEL=IPMODB SEGACT MMODEL NSOUS=KMODEL(/1) C C --- INITIALISATION DU MCHELM DE FORCES C L1=6 N1=NSOUS N3=5 IF(ISOU1.EQ.1) THEN SEGINI MCHELM IPCHE5=MCHELM ifoche=ifour titche='forces' ELSE MCHELM=IPCHE5 SEGACT MCHELM END IF C IFOCHE=IFOUR C TITCHE='FORCES' C C --- BOUCLE SUR LES SOUS ZONES C DO 200 ISOUS=1,NSOUS C nnum = ipnnum(isous) C segact nnum C --- INITIALISATION C IVAMAT=0 IVACAR=0 IVASTR=0 IVAFOR=0 NMATR=0 NMATF=0 NCARA=0 NCARF=0 NFORC=0 MOMATR=0 MOCARA=0 C C --- TRAITEMENT DU MODELE C IMODEL=KMODEL(ISOUS) SEGACT IMODEL MELE=NEFMOD IPMAIL=IMAMOD CONM =CONMOD NFOR=FORMOD(/2) NMAT=MATMOD(/2) MELEME=IPMAIL SEGACT MELEME NBNN=NUM(/1) NBELEM=NUM(/2) C----------------------------------------------- C -on ne construit un champ de force que sur les élements ad hoc segini iccoun C segact nnum nbele = nnm(/2) nbn = nnm(/1) C segini inn1 inmo = inn1 C nbelem = nnm(/2) nbnn = NUM(/1) * write(6,*) 'initial nbelem nbnn ' ,nbelem ,nbnn nbsous =0 nbref = 0 segini ipt4 imaicab= ipt4 ipt4.itypel= itypel ibnew = 0 do 7000 ic=1,nbelem if(nbem(2,IC).ne.isous) goto 7000 ib = nbem(1,IC) if (incor(ib).EQ.0 ) then ibnew = ibnew + 1 incor(ib) = ibnew do 7001 in=1,nbnn ipt4.num(in,ibnew) = num(in,nbem(1,ic)) ibnec = ibnew 7001 continue else ibnec = incor(ib) endif inn1.nbem(1,ic) = ibnec inn1.nbem(2,ic) = isous do 6998 in = 1,nbn inn1.nnm(in,ic) = nnm(in,ic) 6998 continue * write(6,*) 'isous elbet elcab' ,isous, nbem(1,ic),ibnec 7000 continue nbelem = ibnew segadj ipt4 C segdes nnum segdes inn1 segsup iccoun C segdes ipt4 C7002 continue C---------------------------------------------- C C --- RECOPIE DU MCHELM C C C IMACHE(ISOUS)=IPMAIL imache(isous)=imaicab C C --- INFORMATIONS SUR L'ELEMENT FINI C NBPGAU= INFELE(4) NBG = INFELE(6) * MINTE = INFELE(11) minte=INFMOD(5) MINTE1= INFMOD(8) IPMINT= MINTE IPMIN1= MINTE1 MFR = INFELE(13) LW = INFELE(7) NDDL = INFELE(15) LRE = INFELE(9) LVAL = (LRE*(LRE+1))/2 NHRM = NIFOUR C SEGACT MINTE NBNO=SHPTOT(/2) C INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=NIFOUR INFCHE(ISOUS,4)=0 INFCHE(ISOUS,5)=0 C C --- NOMS DE COMPOSANTES NECESSAIRES ( FORCES ) C if(lnomid(2).ne.0) then nomid=lnomid(2) segact nomid moforc=nomid nforc=lesobl(/2) nfac=0 lsupfo=.false. else lsupfo=.true. CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NFAC) endif C C --- CREATION DU MCHAML C --- CAS PARTICULIER MILIEUX POREUX : RIEN SUR FP C --- CAS PARTICULIER DE LA DEFO PLANE GENE : RIEN SUR FZ MY MX C NFOREF=NFORC N2=NFOREF C IF(ISOU1.EQ.1) THEN SEGINI MCHAML ICHAML(ISOUS)=MCHAML ELSE MCHAML=ICHAML(ISOUS) SEGACT MCHAML END IF NOMID=MOFORC SEGACT NOMID C DO 110 ICOMP=1,N2 NOMCHE(ICOMP)=LESOBL(ICOMP) TYPCHE(ICOMP)='REAL*8' 110 CONTINUE if(lsupfo)SEGsup NOMID C C --- TAILLES DE MELVAL C C N1EL=NBELEM C N1PTEL= NBNN n1el=ipt4.num(/2) n1ptel= ipt4.num(/1) * write(6,*) ' support forces n1el n1ptel ', n1el ,n1ptel NBPTEL=NBPGAU C NEL =N1EL C C --- CREATION DU MELVAL DE FORCES C NS=1 NCOSOU=NFOREF IF(IMMD.EQ.2.AND.ISOU1.EQ.1) THEN SEGINI MPTVAL IVAFOR=MPTVAL IVASSS(ISOUS)=IVAFOR ELSE MPTVAL=IVASSS(ISOUS) IVAFOR=MPTVAL SEGACT MPTVAL END IF DO 100 ICOMP=1,NFOREF N2PTEL=0 N2EL=0 IF(IMMD.EQ.2.AND.ISOU1.EQ.1) THEN SEGINI MELVAL IELVAL(ICOMP)=MELVAL IVAL(ICOMP)=MELVAL END IF 100 CONTINUE C CALL LSIGM1(IMAICAB,LRE,NSTRS,NBPGAC,MELE,MELEM,IPCHE1,IPMITC, & NFORC,IVAFOR,ISOUS,ISOU1,IMMD,INMO) C ipt4 = imaicab SEGDES IMODEL,MCHAML,MINTE,ipt4 C IF(IERR.NE.0)THEN IRET=0 GO TO 9991 ENDIF C 200 CONTINUE segsup inn1 segdes nnum C C fin de la boucle sur les sz du modele cable ( 1 pout le moment) 40 CONTINUE C 99999 CONTINUE IF(ISUP1.EQ.1)THEN CALL DTMVAL(IVASTR,3) ELSE CALL DTMVAL(IVASTR,1) ENDIF C CALL DTMVAL(IVAFOR,1) C C --- TRANSFORMATION DU CHAMELEM EN CHPOINT C CALL CHAMPO(IPCHE5,0,IPCHE4,IRET) CALL DTCHAM(IPCHE5) SEGDES MMODEL RETURN 9990 CONTINUE IRET=0 C C --- ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR C IF(ISUP1.EQ.1)THEN CALL DTMVAL(IVASTR,3) ELSE CALL DTMVAL(IVASTR,1) ENDIF CALL DTMVAL(IVAFOR,3) C SEGDES MINTE SEGDES IMODEL 9991 CONTINUE segsup nnum SEGSUP MCHAML C SEGDES MELEME SEGDES MMODEL SEGSUP MCHELM END