C FORMCH SOURCE MB234859 25/09/08 21:15:26 12358 SUBROUTINE FORMCH(IPMODL,IPCHEL,IPT,IRET,IPCHCA1,MCOOR1) C-------------------------------------------------------------------- C C REACTUALISATION DES CARACTERISTIQUES POUR CERTAINES FORMULATIONS C ROUTINE APPELEE PAR FORM C C-------------------------------------------------------------------- C C ENTREES : C --------- C C IPMODL POINTEUR SUR UN MMODEL C IPCHEL POINTEUR SUR UN MCHAML DE CARACTERISTIQUES C IPT POINTEUR SUR UN CHPOINT C Les pointeurs ci-dessus sont actifs en E/S (via FORM/ACTOBJ). C C C SORTIE : C -------- C C IRET 1 SI L'OPERATION EST POSSIBLE C 0 SI L'OPERATION EST IMPOSSIBLE C IPCHCA1 POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUES C C------------------------------------------------------------------- C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMCOORD -INC SMELEME -INC SMMODEL -INC TMPTVAL SEGMENT IWRK REAL*8 XDDL(LRE),XE(3,NBNN),WORK(LW) ENDSEGMENT SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) LOGICAL lsupdp DIMENSION VECT(6) IRET = 0 IPCHCA1 = 0 IPCHDEP = 0 C C SUPPORT des CHAMPS DE CARACTERISTIQUES : C ISUPCA = 3 C C ON VERIFIE QUE LE MCHAML DE CARACTERISTIQUES EST SUR SON SUPPORT C CALL QUESUP (IPMODL,IPCHEL,ISUPCA,1,ISUP,IRETCA) IF (ISUP.NE.0) RETURN C C ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT C Amelioration possible : Ne faire le MCHAML IPCHDEP que si necessaire ? C CALL CHAME1(0,IPMODL,IPT,' ',IPCHDEP,1) IF (IERR.NE.0) RETURN C C ON COPIE LE CHAMELEM DE CARACTERISTIQUES C On ne recopie que le chapeau sans MELVAL -> seuls les melvals devant C etre modifies seront copies plus bas dans la boucle ! mchelm = IPCHEL SEGINI,mchel1=mchelm NSOUS = mchel1.IMACHE(/1) DO IC = 1, NSOUS MCHAM1 = mchel1.ICHAML(IC) SEGINI,MCHAML=MCHAM1 mchel1.ICHAML(IC) = MCHAML ENDDO IPCHE1 = mchel1 c-dbg write(ioimp,*) c-dbg write(ioimp,*)'(E)IPCHE1=',ipche1,NSOUS c-dbg do ic = 1, nsous c-dbg mchaml = mchel1.ICHAML(IC) c-dbg write(ioimp,*)' mchaml=',mchaml,ic,ielval(/1) c-dbg write(ioimp,*)' nomche=',(nomche(id),id=1,ielval(/1)) c-dbg write(ioimp,*)' melval=',(ielval(id),id=1,ielval(/1)) c-dbg enddo C C Un petit segment utile pour les CARACTERISTIQUES : C nbtype = 1 SEGINI,notype notype.TYPE(1) = 'REAL*8' MOTYR8 = NOTYPE C____________________________________________________________________ C C BOUCLE SUR LES SOUS-ZONES DU MODELE : C____________________________________________________________________ C MMODEL=IPMODL NSOUS = KMODEL(/1) DO 200 ISOUS = 1, NSOUS KERRE=0 IMODEL = KMODEL(ISOUS) IPMAIL = IMAMOD MELE = NEFMOD CONM = CONMOD MOCARA=0 IVACAR=0 IVACA1=0 MODEPL=0 IVADEP=0 lsupdp=.false. C____________________________________________________________________ C C INFORMATION SUR L'ELEMENT FINI C____________________________________________________________________ C IFORM=INFELE(13) NBG =INFELE(6) LW =INFELE(7) LRE =INFELE(9) C MELEME=IPMAIL NBNN =NUM(/1) NBELEM=NUM(/2) C C CREATION DU TABLEAU INFOS C C* CALL IDENT(IPMAIL,CONM,IPCHEL,IPCHDEP,INFOS,IRTD) CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHDEP,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 150 C____________________________________________________________________ C C TRAITEMENT DU CHAMP DE CARACTERISTIQUES C____________________________________________________________________ C NBROBL = 0 NBRFAC = 0 NOMID = 0 * * Toutes les caracteristiques sont de type 'REAL*8' (MOTYR8) * * CARACTERISTIQUES POUR LES BARRES * C*? IF (IFORM.EQ.27) THEN C*? NBROBL=1 C*? SEGINI NOMID C*? LESOBL(1)='SECT' * * CARACTERISTIQUES POUR LES POUTRES ET LES TUYAU * IF ((IFORM.EQ.7.OR.IFORM.EQ.13).AND.(IDIM.EQ.3)) THEN NBRFAC=3 SEGINI NOMID LESFAC(1)='VX' LESFAC(2)='VY' LESFAC(3)='VZ' * * CARACTERISTIQUES POUR LES LINESPRING * ELSE IF (IFORM.EQ.15) THEN NBROBL=3 SEGINI NOMID LESOBL(1)='VX ' LESOBL(2)='VY ' LESOBL(3)='VZ ' * * CARACTERISTIQUES POUR LES TUFI * ELSE IF (IFORM.EQ.17) THEN NBROBL=6 SEGINI NOMID LESOBL(1)='VX ' LESOBL(2)='VY ' LESOBL(3)='VZ ' LESOBL(4)='VXF ' LESOBL(5)='VYF ' LESOBL(6)='VZF ' * * (fdp) CARACTERISTIQUES POUR LES JOI1 * ROTATION APPLIQUEE AUX VECTEURS ORIENTANT LE JOINT SI DEMANDEE DANS LE MODELE ! * ELSE IF (IFORM.EQ.75) THEN ITOUR=-1*INFMOD(9) IF (ITOUR.EQ.1) THEN IF (IDIM.EQ.3) THEN NBROBL=6 SEGINI NOMID LESOBL(1)='V1X ' LESOBL(2)='V1Y ' LESOBL(3)='V1Z ' LESOBL(4)='V2X ' LESOBL(5)='V2Y ' LESOBL(6)='V2Z ' ELSE IF (IDIM.EQ.2) THEN NBROBL=2 SEGINI NOMID LESOBL(1)='V1X ' LESOBL(2)='V1Y ' ENDIF ENDIF ENDIF MOCARA = NOMID NCARA = NBROBL NCARF = NBRFAC NCARR = NCARA+NCARF C Pas de caracteristiques a transformer : rien de plus a faire IF (MOCARA.EQ.0) GOTO 150 C* IF (MOCARA.NE.0) THEN CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYR8,1, & INFOS,3,IVACAR) IF (IERR.NE.0) GOTO 150 CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYR8,1, & INFOS,3,IVACA1) IF (IERR.NE.0) GOTO 150 * * IVACAR et IVACA1 pointent vers les memes MELVAL ...et.. * RECOPIE ET AJUSTEMENT DE LA DIMENSION DES MELVAL de IVACA1 * (composantes scalaires 'REAL*8') * MPTVAL = IVACA1 nsca1 = ipos(/1) c-dbg write(ioimp,*)'ivaca1=',ivaca1,nsca1,ival(/1),ipmail c-dbg write(ioimp,*)' ipos=',(ipos(ic),nsof(ic),ic=1,ipos(/1)) c-dbg write(ioimp,*)' ival=',(ival(ic),ic=1,ncarr) DO IC = 1,NCARR MELVA1 = IVAL(IC) IF (MELVA1.NE.0) THEN SEGINI,MELVAL=MELVA1 N1PTEL=VELCHE(/1) N1EL =VELCHE(/2) c* N2PTEL=IELCHE(/1) = 0 ! c* N2EL =IELCHE(/2) = 0 ! C (fdp) correction : on remplace .LT. par .LE. pour gerer le cas ou il C n'y a qu'un seul element C (sinon plantage dans le cas d'un seul element TUFI) IF ((N1EL.LE.NBELEM).OR.(N1PTEL.LE.NBG)) THEN N1EL = MAX(N1EL,NBELEM) N1PTEL= MAX(N1PTEL,NBG) IF (IFORM.EQ.7.OR.IFORM.EQ.13) N1PTEL=1 N2PTEL=0 N2EL =0 SEGADJ,MELVAL ENDIF IVAL(IC) = MELVAL C*-> Il faut mettre MELVAL dans IPCHE1 a la place de MELVA1 ! DO id = 1, nsca1 mchaml = mchel1.ichaml(ipos(id)) call place2(mchaml.ielval(1),ielval(/1),idm,melva1) if (idm.gt.0) then mchaml.ielval(idm) = melval c-dbg write(ioimp,*)'melval found',id,idm,melval,'->',melva1 goto 0312 endif enddo 0312 continue if (idm.eq.0) write(ioimp,*)'MELVAL',melval,'not found' ENDIF ENDDO C* ENDIF C* IF (IVACAR.EQ.0) GOTO 150 C______________________________________________________________________ C C TRAITEMENT DU CHAMP DE DEPLACEMENT C______________________________________________________________________ C IF (lnomid(1).ne.0) THEN MODEPL=lnomid(1) nomid=MODEPL NDEP=nomid.lesobl(/2) nfac=nomid.lesfac(/2) lsupdp=.false. ELSE CALL IDPRIM(IMODEL,IFORM,MODEPL,NDEP,NFAC) lsupdp=.true. ENDIF C C VERIFICATION DE LEUR PRESENCE C CALL KOMCHA(IPCHDEP,IPMAIL,CONM,MODEPL,MOTYR8,1,INFOS,ISUPCA, & IVADEP) IF (IERR.NE.0) GOTO 150 C______________________________________________________________________ C C BRANCHEMENT SELON LES FORMULATIONS S'IL Y A BESOIN C______________________________________________________________________ C C (fdp) on prevoit le cas des elements JOI1 (iform = 75) IF (iform.EQ.75) GOTO 75 IF (iform.GT.38) GOTO 30 GOTO (30,22,30,22,30,22,120,22,30,22,22,22,120,22,90,22, & 70,22,22,22,22,22,22,22,22,22,30,22,22,22,30,22,30,22, & 30,22,22,22),IFORM C_______________________________________________________________________ C C FORMULATION MASSIVE - RIEN DE SPECIAL A FAIRE C FORMULATION POREUSE - RIEN DE SPECIAL A FAIRE C FORMULATIONS COQUE - ON NE FAIT RIEN C FORMULATIONS UNIAXIALE - ON NE FAIT RIEN C AUTRE(S) FORMULATION(S) : RIEN A FAIRE C_______________________________________________________________________ C 22 CONTINUE 30 CONTINUE GOTO 150 C______________________________________________________________________ C C FORMULATION LINESPRING C______________________________________________________________________ C 90 CONTINUE SEGINI IWRK DO IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS C CALL DOXE(MCOOR1.XCOOR,IDIM,NBNN,NUM,IB,XE) IE=1 MPTVAL=IVADEP DO IGAU=1,NBNN DO IC=1,NDEP MELVAL=IVAL(IC) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 ENDDO ENDDO C DO IC=1,NBG IF (IC.EQ.2) GO TO 948 MPTVAL=IVACAR DO ID=1,3 MELVAL=IVAL(ID) IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) VECT(ID)=VELCHE(IGMN,IBMN) ENDDO ICC=1 IF(IC.GT.1) ICC=2 CALL LSPFRM(IWRK,KERRE,VECT,ICC) C IF(KERRE.NE.0) THEN INTERR(1)=ISOUS INTERR(2)=IB GO TO 927 ENDIF C C REMPLISSAGE C 948 CONTINUE MPTVAL=IVACA1 DO ID=1,3 MELVAL=IVAL(ID) VELCHE(IC,IB)=VECT(ID) enddo enddo ENDDO C 927 SEGSUP IWRK GOTO 151 C_______________________________________________________________________ C C FORMULATION TUYAU FISSURE C_______________________________________________________________________ C 70 CONTINUE SEGINI IWRK DO IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS C CALL DOXE(MCOOR1.XCOOR,IDIM,NBNN,NUM,IB,XE) MPTVAL=IVADEP IE=1 DO IC=1,NBNN DO ID=1,NDEP MELVAL=IVAL(ID) IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo C MPTVAL=IVACAR DO ID=1,6 MELVAL=IVAL(ID) IBMN=MIN(IB,VELCHE(/2)) VECT(ID)=VELCHE(1,IBMN) ENDDO C CALL TUYFRM(IWRK,KERRE,VECT,VECT(4)) C IF(KERRE.NE.0) THEN INTERR(1)=ISOUS INTERR(2)=IB GO TO 727 ENDIF C C REMPLISSAGE C MPTVAL=IVACA1 DO IC=1,NBG DO ID=1,6 MELVAL=IVAL(ID) VELCHE(IC,IB)=VECT(ID) enddo enddo ENDDO C 727 SEGSUP IWRK GOTO 151 C_______________________________________________________________________ C C (fdp) FORMULATION JOINT 1 AVEC REPERE LOCAL LIE C_______________________________________________________________________ C 75 CONTINUE SEGINI IWRK C c* Test fait plus haut : ITOUR=-1*INFMOD(9) C DO IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS, LES DEPLACEMENTS ET C LES ROTATIONS C CALL DOXE(MCOOR1.XCOOR,IDIM,NBNN,NUM,IB,XE) IE=1 DO IC=1,NBNN MPTVAL=IVADEP DO ID=1,NDEP MELVAL=IVAL(ID) IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 ENDDO ENDDO C C ON CHERCHE LES VECTEURS ORIENTANT L'ELEMENT JOINT DANS LE C CHAMP DE CARACTERISTIQUES C MPTVAL=IVACAR DO IC=1,NCARA MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) VECT(IC)=VELCHE(1,IBMN) ENDDO C C ON APPLIQUE LA ROTATION AUX VECTEURS ORIENTANT LE JOINT C c* Test fait plus haut : IF (ITOUR.EQ.1) THEN CALL JOIFRM(IWRK,KERRE,VECT,IDIM) IF (KERRE.EQ.1) THEN CALL ERREUR(277) GOTO 150 ENDIF c* Test fait plus haut : ENDIF C C REMPLISSAGE DU CHAMP DE CARACTERISTIQUES AVEC LES NOUVEAUX C VECTEURS C MPTVAL=IVACA1 DO IC=1,NCARA MELVAL=IVAL(IC) VELCHE(1,IB)=VECT(IC) ENDDO C ENDDO C SEGSUP IWRK GOTO 151 C_______________________________________________________________________ C C FORMULATION POUTRE ET TUYAU C_______________________________________________________________________ C 120 CONTINUE SEGINI IWRK C DO IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS C CALL DOXE(MCOOR1.XCOOR,IDIM,NBNN,NUM,IB,XE) IE=1 DO IC=1,NBNN MPTVAL=IVADEP DO ID=1,NDEP MELVAL=IVAL(ID) IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo C MPTVAL=IVACAR do id=1,3 MELVAL=IVAL(id) IBMN=MIN(IB,VELCHE(/2)) VECT(id)=vELCHE(1,IBMN) enddo CALL POUFRM(IWRK,KERRE,VECT) C IF(KERRE.NE.0) THEN INTERR(1)=ISOUS INTERR(2)=IB GO TO 127 ENDIF C C REMPLISSAGE C MPTVAL=IVACA1 DO ID=1,3 MELVAL=IVAL(ID) VELCHE(1,IB)=VECT(ID) enddo ENDDO C 127 SEGSUP IWRK GOTO 151 C_______________________________________________________________________ C C AUTRE FORMULATION C_______________________________________________________________________ C 151 CONTINUE IF(KERRE.EQ.1) CALL ERREUR(128) IF(KERRE.EQ.2) CALL ERREUR(138) IF(KERRE.EQ.3) CALL ERREUR(277) 150 CONTINUE IF (MOCARA.NE.0) THEN nomid=MOCARA SEGSUP,NOMID MPTVAL=IVACAR SEGSUP,MPTVAL MPTVAL=IVACA1 SEGSUP,MPTVAL ENDIF IF (MODEPL.NE.0) THEN nomid=MODEPL if (lsupdp) SEGSUP,NOMID MPTVAL=IVADEP SEGSUP,MPTVAL ENDIF IF (KERRE.NE.0) GOTO 9990 IF (IERR.NE.0) GOTO 9990 C 200 CONTINUE C * remettre mchel1 en read CALL ACTOBJ('MCHAML ',MCHEL1,1) IRET = 1 IPCHCA1 = IPCHE1 c-dbg write(ioimp,*)'(S)IPCHE1=',ipche1,NSOUS c-dbg do ic = 1, nsous c-dbg mchaml = mchel1.ICHAML(IC) c-dbg write(ioimp,*)'mchaml=',mchaml,ic,ielval(/1) c-dbg write(ioimp,*)' nomche=',(nomche(id),id=1,ielval(/1)) c-dbg write(ioimp,*)' melval=',(ielval(id),id=1,ielval(/1)) c-dbg enddo 9990 CONTINUE notype = MOTYR8 SEGSUP,notype *? IF (IPCHDEP.NE.0) CALL DTCHAM(IPCHDEP) RETURN END