C DECO1 SOURCE MB234859 25/09/08 21:15:20 12358 SUBROUTINE DECO1(IPMODL,IPCHE2,IPCHE1,IPCHL1,IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *____________________________________________________________________* * * * Sous-programme de l'op{rateur DECO * * * * Entr{es: * * * * IPMODL Pointeur sur un objet MMODEL * * IPCHE2 Pointeur sur un MCHAML de FONCTION DE COURANT * * IPCHE1 Pointeur sur un MCHAML de CARACTERISTIQUES * * * * Sortie: * * * * IPCHL1 Pointeur sur un MCHAML de courants * * IRET 1 si succes , 0 sinon * * * * Auteurs, date de cr{ation: * * * * Yann Stephan, le 22/09/97 * * * *____________________________________________________________________* * -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMMODEL -INC SMELEME -INC SMINTE -INC SMCOORD -INC TMPTVAL SEGMENT,MMAT1 REAL*8 VALMAT(NMATR) REAL*8 XE(3,NBNN),XE1(3,NBNN) REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN,NBPGAU) REAL*8 COSD1(3),COSD2(3) ENDSEGMENT POINTEUR MMAT2.MMAT1,MMATX.MMAT1 * SEGMENT SGAUSS REAL*8 XGAUSS(3,NBPGAU) REAL*8 DX(NBPGAU) ENDSEGMENT POINTEUR SGX.SGAUSS,SGY.SGAUSS * SEGMENT,MWRK1 REAL*8 XDDL(LRE) ENDSEGMENT * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) LOGICAL lsupgd lsupgd=.false. IRET=1 MWRK1=0 NMAT = 0 ITHER= 0 IMAGN= 0 NHRM = NIFOUR * * ACTIVATION DU CHAPEAU DE MODELE * MMODEL = IPMODL SEGACT MMODEL NSOUS = KMODEL(/1) * * Initialisation du CHAMELEM de COURANTS * L1 = 8 N1 = NSOUS N3 = 6 SEGINI,MCHELM IPCHL1=MCHELM TITCHE = 'COURANT' IFOCHE=IFOUR * * Boucle sur les zones {l{mentaires du MODELE * DO 500 ISOUS=1,NSOUS * * QUELQUES INITIALISATIONS * NGRA=0 NDEP=0 NCAR = 0 IPMINT=0 IRTD1=1 NSTRS=0 MOGRAD=0 MODEPL=0 MOTEMP=0 MOCARA=0 MOMATR=0 IVAGRA=0 IVADEP=0 IVACAR=0 IVAMAT=0 NMATR=0 NMATF=0 * IMODEL=KMODEL(ISOUS) SEGACT IMODEL MELE=NEFMOD IPMAIL=IMAMOD CONM =CONMOD NFOR=FORMOD(/2) NMAT=MATMOD(/2) CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) IF (CMATE.EQ.' ')THEN CALL ERREUR(251) SEGDES IMODEL,MMODEL SEGSUP MCHELM IRET=0 RETURN ENDIF CALL PLACE(FORMOD,FORMOD(/2),IMAGN,'MAGNETODYNAMIQUE') * * ACTIVATION DU MAILLAGE * MELEME=IPMAIL SEGACT,MELEME NBNN =NUM(/1) NBELEM=NUM(/2) NBNO=NBNN * * INFORMATIONS SUR L'ELEMENT FINI * * IF(IMAGN.NE.0) THEN MFR = INFELE(13) MINTE = INFMOD(4) MINTE1= INFMOD(3) NSTRS = INFELE(16) LW = INFELE( 7) LRE = INFELE( 9) LHOOK = INFELE(10) ENDIF * * ACTIVATION DU SEGMENT D'INTEGRATION * SEGACT,MINTE NBPGAU=POIGAU(/1) SEGINI SGAUSS NDIM=IDIM SEGINI MMAT1 C C CREATION DU TABLEAU INFOS C CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 9990 * * NOMS DE COMPOSANTES OBLIGATOIRES A TROUVER DANS LES CHAMELEMS * if(lnomid(3).ne.0) then nomid=lnomid(3) segact nomid mograd=nomid ngra=lesobl(/2) nfac=lesfac(/2) lsupgd=.false. else lsupgd=.true. CALL IDGRAD(IMODEL,IFOUR,MOGRAD,NGRA,NFAC) endif * IF(IMAGN.NE.0) THEN CALL IDFC(MFR,IFOUR,MOFC,NDEP,NFAC) ENDIF * * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES * NBROBL=0 NBRFAC=0 MOCARA=0 NCAR=0 * IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN NBROBL=1 NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESOBL(1)='EPAI' LESFAC(1)='EXCE' NCAR=1 ENDIF * * VERIFICATION DE PRESENCE DES COMPOSANTES * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' IF(IMAGN.NE.0) THEN CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOFC, 1 MOTYPE,1,INFOS,3,IVADEP) ENDIF SEGSUP NOTYPE IF (IERR.NE.0) THEN NGRA=0 IF (NCAR.NE.0) THEN NOMID=MOCARA SEGSUP NOMID ENDIF MOCARA=0 NCAR=0 GOTO 9990 ENDIF * IF (NCAR.NE.0) THEN IF (IPCHE1.NE.0) THEN NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE, 1 1,INFOS,3,IVACAR) SEGSUP NOTYPE ELSE MOTERR(1:8)='CARACTER' MOTERR(9:12)=NOMTP(MELE) MOTERR(13:20)='COURANT' CALL ERREUR(145) NCAR=0 NGRA=0 NOMID=MOCARA SEGSUP NOMID MOCARA=0 GOTO 9990 ENDIF ENDIF IF (IERR.NE.0) GOTO 9990 * IF(IVACAR.NE.0)THEN MPTVAL=IVACAR IPMELV=IVAL(1) CALL QUELCH(IPMELV,ICONS) IF(ICONS.NE.0)THEN CALL ERREUR(566) GOTO 9990 ENDIF ENDIF * NBROBL=0 NBRFAC=0 MOMATR=0 NMATR=0 NMATF=0 * * CREATION DU MCHAML DE COURANT * N2=NGRA SEGINI,MCHAML ICHAML(ISOUS)=MCHAML IMACHE(ISOUS)=MELEME CONCHE(ISOUS)=CONMOD C INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=NHRM INFCHE(ISOUS,4)=MINTE INFCHE(ISOUS,5)=0 IF(IMAGN.NE.0) THEN INFCHE(ISOUS,6)=2 ENDIF * * RECHERCHE DES DIMENSIONS LES PLUS GRANDES * N1EL=0 N1PTEL=0 MPTVAL=IVADEP DO 178 IO=1,NDEP MELVAL=IVAL(IO) N1PTEL=MAX(N1PTEL,VELCHE(/1)) N1EL =MAX(N1EL ,VELCHE(/2)) 178 CONTINUE * IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN N1PTEL=1 ELSE N1PTEL=NBPGAU ENDIF N1EL =MIN(N1EL ,NBELEM) * * CREATION DES MELVAL DU COURANT * NSR=1 NCOSOR=NGRA SEGINI MPTVAL IVAGRA=MPTVAL NOMID=MOGRAD SEGACT NOMID DO 77 IGR=1,NGRA TYPCHE(IGR)='REAL*8' NOMCHE(IGR)=LESOBL(IGR) N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(IGR)=MELVAL IVAL(IGR)=MELVAL 77 CONTINUE SEGDES NOMID * IMESS = 0 NBBB=NBNO IF (MFR.EQ.29) THEN NDUM=NGRA NGRA=NDUM*NBBB SEGINI MWRK1 NGRA=NDUM ELSE SEGINI MWRK1 ENDIF * * Boucle sur les {l{ments * DO 100 IB=1,NBELEM * * On cherche les coordonn{es des noeuds de l'{l{ment IB * CALL DOXE(XCOOR,IDIM,NBNO,NUM,IB,XE) * * On cherche les d{placements ou les temp{ratures * IE=1 MPTVAL=IVADEP NDDD=NDEP IF (IFOUR.EQ.-3.AND.ITHER.EQ.0) NDDD=NDEP-3 DO 200 IGAU=1,NBNN DO 201 ICOMP=1,NDDD MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) ELSE XDDL(IE)=0. ENDIF IE=IE+1 201 CONTINUE 200 CONTINUE * * On se dirige vers la zone sp{cifique selon l'{l{ment * GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, & 99,99,99,99,99,99,99,27),MELE * 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='COURANT' IMESS = 86 GOTO 9990 *____________________________________________________________________* * 2/ COQ3 * *____________________________________________________________________* 27 CONTINUE IF(IMAGN.NE.0)THEN C COQUE MAGNETODYNAMIQUE CALL COQLOC(NBNN,XE,COSD1,COSD2,XE1) CALL ELGAUS(MINTE,MMAT1,SGAUSS,IFOIS,IFOI2) C * LE JACOBIEN EST NEGATIF : MAILLAGE INCORRECT * IF(IFOIS.NE.0.AND.IFOIS.NE.NBPGAU)THEN INTERR(1)=IB CALL ERREUR(195) GO TO 9990 * * CAS OU LE JACOBIEN EST TRES PETIT * ELSEIF(IFOI2.EQ.NBPGAU)THEN INTERR(1)=IB CALL ERREUR (259) GO TO 9990 ENDIF C C REMPLISSAGE C MPTVAL=IVAGRA DO 5027 IGAU=1,NBPGAU DO IC=1,NGRA MELVAL=IVAL(IC) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) r_z = 0.D0 DO IN=1,NBNN r_z = r_z + GRAD(IC,IN,IGAU)*XDDL(IN) ENDDO VELCHE(IGMN,IBMN)=VELCHE(IGMN,IBMN) + r_z ENDDO 5027 CONTINUE * ENDIF * 100 CONTINUE * * D{sactivation des segments * IF (MWRK1.NE.0) SEGSUP,MWRK1 * CALL DTMVAL(IVADEP,1) CALL DTMVAL(IVACAR,1) CALL DTMVAL(IVAMAT,1) CALL DTMVAL(IVAGRA,1) * IF (ITHER.NE.0) THEN NOMID=MOTEMP SEGSUP NOMID ELSE IF(IMAGN.NE.0) THEN NOMID=MOFC SEGSUP NOMID ELSE NOMID=MODEPL SEGSUP NOMID ENDIF IF (MOCARA.NE.0) THEN NOMID=MOCARA SEGSUP NOMID ENDIF IF (MOMATR.NE.0) THEN NOMID=MOMATR SEGSUP NOMID ENDIF NOMID=MOGRAD if(lsupgd)SEGSUP NOMID SEGDES,IMODEL,MELEME SEGDES,MCHAML,MINTE * 500 CONTINUE SEGDES,MMODEL,MCHELM RETURN * 9990 CONTINUE * * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR * IRET=0 * * Gestion des messages d'erreur * IF (IMESS.NE.0) THEN INTERR(1) = IB CALL ERREUR(IMESS) ENDIF * IF (MWRK1.NE.0) SEGSUP,MWRK1 SEGSUP MMAT1 SEGSUP SGAUSS * CALL DTMVAL(IVADEP,1) CALL DTMVAL(IVACAR,1) CALL DTMVAL(IVAMAT,1) CALL DTMVAL(IVAGRA,3) * IF (MODEPL.NE.0) THEN NOMID=MODEPL SEGSUP NOMID ENDIF IF (MOTEMP.NE.0) THEN NOMID=MOTEMP SEGSUP NOMID ENDIF IF (MOCARA.NE.0)THEN NOMID=MOCARA SEGSUP NOMID ENDIF IF (lsupgd.and.MOGRAD.NE.0)THEN NOMID=MOGRAD SEGSUP NOMID ENDIF IF(MOMATR.NE.0)THEN NOMID=MOMATR SEGSUP NOMID ENDIF SEGDES MELEME SEGDES IMODEL SEGDES MMODEL IF (IPCHE1.NE.0) THEN MCHELM=IPCHE1 SEGDES MCHELM ENDIF SEGSUP,MCHAML SEGSUP,MCHELM SEGDES MINTE RETURN END