C FORMCH SOURCE CHAT 12/01/17 21:15:19 7250 SUBROUTINE FORMCH(IPMODL,IPCHEL,IRET,IPT,IPCH1) C C-------------------------------------------------------------------- C C REACTUALISATION DES CARACTERISTIQUES POUR CERTAINES FORMULATIONS C ROUTINE APPELE PAR FOMM 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 C C SORTIE : C -------- C C IRET 1 SI L'OPERATION EST POSSIBLE C 0 SI L'OPERATION EST IMPOSSIBLE C IPCH1 POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUES C C C PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 20 09 90 C C------------------------------------------------------------------- C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMCHAML -INC SMCOORD -INC SMELEME -INC SMMODEL -INC CCOPTIO -INC CCHAMP C SEGMENT IWRK REAL*8 XDDL(LRE),XE(3,NBNN),WORK(LW) ENDSEGMENT C SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT C SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT C CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) LOGICAL lsupdp C C DIMENSION VECT(6) * C C ON VERIFIE QUE LE MCHAML DE CARACTERISTIQUE EST SUR SON SUPPORT C CALL QUESUP (IPMODL,IPCHEL,3,1,ISUP,IRETCA) IF (ISUP.NE.0) THEN IRET=0 RETURN ENDIF C C C ON COPIE LE CHAMELEM DE CARACTERISTIQUES C CALL COPIE8(IPCHEL,IPCH1) C C ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT C CALL CHAME1(0,IPMODL,IPT,' ',IPCHAM1,1) IF (IERR.NE.0) THEN CALL DTCHAM(IPCH1) IRET=0 RETURN ENDIF C C ACTIVATION DU MODELE C IRET=1 MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) NSOU1=NSOUS C____________________________________________________________________ C C BOUCLE SUR LES SOUS-ZONES C____________________________________________________________________ C DO 200 ISOUS=1,NSOU1 KERRE=0 IVACAR=0 IVACA1=0 IVADEP=0 C C ON RECUPERE L INFORMATION GENERALE C IMODEL=KMODEL(ISOUS) SEGACT IMODEL IPMAIL=IMAMOD CONM =CONMOD C C TRAITEMENT DU MODELE C MELE=NEFMOD MELEME=IMAMOD C____________________________________________________________________ C C INFORMATION SUR L'ELEMENT FINI C____________________________________________________________________ C CALL ELQUOI(MELE,0,6,IPINF,IMODEL) IF (IERR.NE.0) THEN SEGDES IMODEL,MMODEL CALL DTCHAM(IPCH1) CALL DTCHAM (IPCHAM1) IRET=0 RETURN ENDIF C INFO=IPINF IFORM=INFELL(13) NBG =INFELL(6) ICARA=INFELL(5) LW =INFELL(7) LRE =INFELL(9) C C ACTIVATION DU MELEME C SEGACT MELEME NBNN =NUM(/1) NBELEM=NUM(/2) C C CREATION DU TABLEAU INFOS C CALL IDENT(IPMAIL,CONM,IPCH1,IPCHAM1,INFOS,IRTD) IF (IRTD.EQ.0) THEN NCARA=0 NCARF=0 NDEP=0 MOCARA=0 MODEPL=0 GOTO 9990 ENDIF C C RECHERCHE DES NOMS DE COMPOSANTES C if(lnomid(1).ne.0) then nomid=lnomid(1) segact nomid modepl=nomid ndep=lesobl(/2) nfac=lesfac(/2) lsupdp=.false. else lsupdp=.true. CALL IDDEPL(IFORM,IFOUR,MODEPL,NDEP,NFAC) endif C C VERIFICATION DE LEUR PRESENCE C NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' CALL KOMCHA(IPCHAM1,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP) SEGSUP NOTYPE IF (IERR.NE.0) THEN NCARA=0 NCARF=0 MOCARA=0 GOTO 9990 ENDIF C____________________________________________________________________ C * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES * C____________________________________________________________________ C NBROBL=0 NBRFAC=0 MOCARA=0 NCARA=0 NCARF=0 NCARR=0 IVECT=0 * * CARACTERISTIQUES POUR LES BARRES * IF (IFORM.EQ.27) THEN NBROBL=1 SEGINI NOMID MOCARA=NOMID LESOBL(1)='SECT' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * CARACTERISTIQUES POUR LES POUTRES ET LES TUYAU * ELSE IF (IFORM.EQ.7.OR.IFORM.EQ.13) THEN NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESFAC(1)='VECT' IVECT=1 * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='POINTEURPOINT ' * * CARACTERISTIQUES POUR LES LINESPRING * ELSE IF (IFORM.EQ.15) THEN NBROBL=3 SEGINI NOMID MOCARA=NOMID LESOBL(1)='VX ' LESOBL(2)='VY ' LESOBL(3)='VZ ' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * CARACTERISTIQUES POUR LES TUFI * ELSE IF (IFORM.EQ.17) THEN NBROBL=6 SEGINI NOMID MOCARA=NOMID LESOBL(1)='VX ' LESOBL(2)='VY ' LESOBL(3)='VZ ' LESOBL(4)='VXF ' LESOBL(5)='VYF ' LESOBL(6)='VZF ' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' ENDIF * IF (MOCARA.NE.0) THEN * CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) * write (6,*) ' formch apres komcha 1 ivacar ',ivacar IF (IERR.NE.0)THEN SEGSUP NOTYPE GOTO 9990 ENDIF CALL KOMCHA(IPCH1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACA1) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 IF (IVECT.EQ.1) THEN MPTVAL=IVACAR IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN * * MOT CLE VECT EN CAS DE CONVERSION * IVECT=2 NOMID=MOCARA SEGSUP NOMID NBRFAC=0 NBROBL=3 SEGINI NOMID MOCARA=NOMID LESOBL(1)='VX ' LESOBL(2)='VY ' LESOBL(3)='VZ ' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) * write (6,*) ' formch apres komcha 2 ivacar ',ivacar IF (IERR.NE.0)THEN SEGSUP NOTYPE GOTO 9990 ENDIF CALL KOMCHA(IPCH1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACA1) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 ENDIF ENDIF ENDIF NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF IF (MOCARA.NE.0) SEGDES NOMID * * AJUSTEMENT DE LA DIMENSION DES MELVAL * if ((iform.eq.7).OR.(iform.eq.13).OR.(iform.eq.15) & .OR.(iform.eq.17)) then IF (NCARR.NE.0) THEN MPTVAL=IVACAR MELVAL=IVAL(1) IF(IVECT.EQ.1) THEN N2EL =IELCHE(/2) IF(N2EL.LT.NBELEM) THEN N2EL = NBELEM N2PTEL= 1 N1EL = 0 N1PTEL= 0 MPTVAL=IVACA1 MELVAL=IVAL(1) SEGADJ MELVAL ENDIF ELSE N1PTEL=VELCHE(/1) N1EL =VELCHE(/2) IF((N1EL.LT.NBELEM).OR.(N1PTEL.LT.NBG)) THEN N1EL = MAX(N1EL,NBELEM) N1PTEL= MAX(N1PTEL,NBG) N2EL = 0 N2PTEL= 0 IF (IFORM.EQ.7.OR.IFORM.EQ.13) N1PTEL=1 MPTVAL=IVACA1 DO 128 ID=1,NBROBL MELVAL=IVAL(ID) SEGADJ MELVAL 128 CONTINUE ENDIF ENDIF ENDIF endif * * * MASSI COQUE COQEP POUT CIST THER TUYA LISP * if(iform.gt.38) go to 30 GOTO (30,22,30,22,30,22,120,22,30,22,22,22,120,22,90,22, * * TUFI RCMA RCCO SULI MEMB UNIA THER INCO PORE * . 70,22,22,22,22,22,22,22,22,22,30,22,22,22,22,22,30,22, * * RACO HOMO * . 30,22,22,22),IFORM C 22 CONTINUE IRET=0 MOTERR(1:8)=NOMFR(IFORM) CALL ERREUR(193) GOTO 9990 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______________________________________________________________________ C 30 CONTINUE GOTO 150 C______________________________________________________________________ C C FORMULATION LINESPRING C______________________________________________________________________ C 90 CONTINUE IAD=2 SEGINI IWRK DO 921 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) IE=1 DO 9207 IGAU=1,NBNN MPTVAL=IVADEP DO 9207 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 9207 CONTINUE C DO 921 IC=1,NBG MPTVAL=IVACAR IF(IC.EQ.2) GO TO 948 DO 923 ID=1,3 MELVAL=IVAL(ID) IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) VECT(ID)=VELCHE(IGMN,IBMN) 923 CONTINUE 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 921 ID=1,3 MELVAL=IVAL(ID) VELCHE(IC,IB)=VECT(ID) * 921 CONTINUE C 927 SEGSUP IWRK GOTO 151 C_______________________________________________________________________ C C FORMULATION TUYAU FISSURE C_______________________________________________________________________ C 70 CONTINUE SEGINI IWRK DO 721 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) IE=1 DO 7207 IC=1,NBNN MPTVAL=IVADEP DO 7207 ID=1,NDEP MELVAL=IVAL(ID) IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 7207 CONTINUE C MPTVAL=IVACAR DO 723 ID=1,6 MELVAL=IVAL(ID) IBMN=MIN(IB,VELCHE(/2)) VECT(ID)=VELCHE(1,IBMN) 723 CONTINUE 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 DO 721 IC=1,NBG MPTVAL=IVACA1 DO 726 ID=1,6 MELVAL=IVAL(ID) VELCHE(IC,IB)=VECT(ID) 726 CONTINUE C 721 CONTINUE C 727 SEGSUP IWRK GOTO 151 C_______________________________________________________________________ C C FORMULATION POUTRE ET TUYAU C_______________________________________________________________________ C 120 CONTINUE SEGINI IWRK C DO 121 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) IE=1 DO 1207 IC=1,NBNN MPTVAL=IVADEP DO 1207 ID=1,NDEP MELVAL=IVAL(ID) IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 1207 CONTINUE C C CAS OU ON A LU LE MOT VECTEUR C MPTVAL=IVACAR IF (IVECT.EQ.1) THEN MELVAL=IVAL(NCARR) IBMN=MIN(IB,IELCHE(/2)) IP=IELCHE(1,IBMN) IREF=(IP-1)*(IDIM+1) DO 6129 IC=1,IDIM VECT(IC)=XCOOR(IREF+IC) 6129 CONTINUE DENSIT=XCOOR(IREF+(IDIM+1)) C C CAS DU CHAMELEM COMVERTI C ELSE IF (IVECT.EQ.2) THEN DO 6429 IC=1,3 MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) VECT(IC)=VELCHE(1,IBMN) 6429 CONTINUE ENDIF C 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 IF (IVECT.EQ.1) THEN C C ON RECREE UN VECTEUR --> MISE A JOUR DU POINTEUR IELCHE C SEGACT MCOORD C NOMBRE DE NOEUDS NBNO=XCOOR(/1)/(IDIM+1) NBNOI=NBNO NBPTS=NBNO+1 SEGADJ MCOORD C C ON CREE LE NOEUD NBNO+1 C XCOOR(NBNOI*(IDIM+1)+1)= VECT(1) XCOOR(NBNOI*(IDIM+1)+2)= VECT(2) IF (IDIM.EQ.3) XCOOR(NBNOI*(IDIM+1)+3)= VECT(3) XCOOR(NBNOI*(IDIM+1)+(IDIM+1))= DENSIT IPOINT = NBPTS * MPTVAL=IVACA1 MELVAL=IVAL(1) SEGACT MELVAL*MOD IELCHE(1,IB)=IPOINT ELSE MPTVAL=IVACA1 DO 126 ID=1,3 MELVAL=IVAL(ID) VELCHE(1,IB)=VECT(ID) 126 CONTINUE ENDIF 121 CONTINUE C C 127 SEGSUP IWRK GOTO 151 C C AUTRE FORMULATION 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 SEGDES MELEME SEGSUP INFO SEGDES IMODEL MPTVAL=IVACAR IF (MPTVAL.NE.0) THEN SEGACT MPTVAL DO 152 I=1,ival(/1) IF (IVAL(I).NE.0) THEN MELVAL=IVAL(I) SEGDES MELVAL ENDIF 152 CONTINUE IF (MOCARA.NE.0) SEGSUP MPTVAL ENDIF C MPTVAL=IVACA1 IF (MPTVAL.NE.0) THEN SEGACT MPTVAL DO I=1,IVAL(/1) IF (IVAL(I).NE.0) THEN MELVAL=IVAL(I) SEGDES MELVAL ENDIF ENDDO IF (MOCARA.NE.0) SEGSUP MPTVAL ENDIF C MPTVAL=IVADEP IF (MPTVAL.NE.0) THEN SEGACT MPTVAL DO 153 I=1,ival(/1) IF (IVAL(I).NE.0) THEN MELVAL=IVAL(I) SEGDES MELVAL ENDIF 153 CONTINUE SEGSUP MPTVAL ENDIF C NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID NOMID=MODEPL if(lsupdp)SEGSUP NOMID C IF(KERRE.NE.0) THEN IRET=0 SEGDES MMODEL CALL DTCHAM(IPCHAM1) CALL DTCHAM(IPCH1) RETURN ENDIF C 200 CONTINUE C CALL DTCHAM(IPCHAM1) SEGDES MMODEL RETURN C 9990 CONTINUE C C ERREUR DANS UNE SOUS ZONE DESACTIVATION ET RETOUR C SEGDES MELEME * SEGSUP INFO SEGDES IMODEL MPTVAL=IVACAR DO 9152 I=1,IVAL(/1) IF (IVAL(I).NE.0) THEN MELVAL=IVAL(I) SEGDES MELVAL ENDIF 9152 CONTINUE IF (MOCARA.NE.0) SEGSUP MPTVAL C MPTVAL=IVACA1 DO I=1,IVAL(/1) IF (IVAL(I).NE.0) THEN MELVAL=IVAL(I) SEGDES MELVAL ENDIF ENDDO IF (MOCARA.NE.0) SEGSUP MPTVAL C MPTVAL=IVADEP DO 9153 I=1,IVAL(/1) IF (IVAL(I).NE.0) THEN MELVAL=IVAL(I) SEGDES MELVAL ENDIF 9153 CONTINUE IF (MODEPL.NE.0) SEGSUP MPTVAL C NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID NOMID=MODEPL IF (MODEPL.NE.0.and.lsupdp) SEGSUP NOMID C RETURN END