C MANUC5 SOURCE OF166741 26/05/21 21:15:09 12556 *--------------------------------------------------------------------* * * * CREATION D'UN NOUVEAU CHAMELEM PAR MANU * * * *--------------------------------------------------------------------* SUBROUTINE MANUC5 IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMLMOTS -INC SMLREEL -INC SMLENTI -INC SMELEME -INC SMMODEL CHARACTER*(LOCOMP) MOCOMP CHARACTER*4 MOT4 CHARACTER*8 MOCHOY CHARACTER*8 CAR CHARACTER*16 JECONS CHARACTER*(LOCHAI) JEROME,CHAIN1 CHARACTER*4 MOTYPE(3),REPA(1) CHARACTER*8 LISMOT(5) DATA MOTYPE/'TYPE','CONS','EVOL'/ DATA REPA /'REPA'/ DATA LISMOT/'NOEUD ','GRAVITE ','RIGIDITE', & 'MASSE ','STRESSES'/ * * Initialisation des segments * IPMODL = 0 IPMAIL = 0 IPLAC = 0 * * LECTURE D'UN MODELE * CALL LIROBJ('MMODEL ',IPMODL,0,IRET) IF (IERR.NE.0) RETURN IF (IRET .EQ. 1) THEN CALL ACTOBJ('MMODEL ',IPMODL,1) IF (IERR.NE.0) RETURN * * SINON D'UN MAILLAGE * ELSE MOTERR(1:8)='MAILLAGE' CALL MESLIR(-137) CALL LIROBJ('MAILLAGE',IPMAIL,0,IRET) IF (IERR.NE.0) RETURN IF (IRET.EQ.1) THEN CALL ACTOBJ('MAILLAGE',IPMAIL,1) IF (IERR.NE.0) RETURN * * SINON lecture du mot EVOL * ELSE CALL LIRMOT(MOTYPE(3),1,IPLAC,0) IF (IERR.NE.0) RETURN IF (IPLAC.NE.1) THEN CALL ERREUR(907) RETURN ENDIF CALL MANUC8 RETURN ENDIF ENDIF JG = 0 JGN = LOCOMP JGM = 0 CALL oooprl(1) SEGINI,MLMOTS,MLMOT1,MLMOT2,MLMOT3,MLREE1,MLENT2 CALL oooprl(0) L1 = 0 JEROME = ' ' LL1 = 0 JECONS = ' ' IPLAC = 0 itart = 0 ISYNT2 = 0 * Syntaxe 2 : MLMOTS_Composante MLREEL_Valeur CALL LIROBJ('LISTMOTS',MLMOT4,0,ISYNT2) IF (IERR.NE.0) GOTO 99 IF (ISYNT2.NE.0) THEN CALL LIROBJ('LISTREEL',MLREEL,1,iret) IF (IERR.NE.0) GOTO 99 SEGACT,MLMOT4,MLREEL NC = MLMOT4.MOTS(/2) NR = MLREEL.PROG(/1) JGM = NC JGN = LOCOMP JG = NC SEGADJ,MLMOT1,MLREE1 DO I = 1, NC MLMOT1.MOTS(I) = MLMOT4.MOTS(I) ENDDO IF (NR.GE.NC) THEN DO I = 1, NC MLREE1.PROG(I) = MLREEL.PROG(I) ENDDO ELSE DO I = 1, NR MLREE1.PROG(I) = MLREEL.PROG(I) ENDDO DO I = NR+1, NC MLREE1.PROG(I) = 0.D0 ENDDO ENDIF SEGDES,MLMOT4,MLREEL c* Test si NC = 0 ? NR = 0 ? ELSE * Syntaxe 1 : Recherche du mot-cle 'REPA' c* dans le CAS OU MODELE EST FOURNI c* IF (IPMODL.NE.0) THEN CALL LIRMOT(REPA,1,itart,0) IF (IERR.NE.0) GOTO 99 c* ENDIF ENDIF * 10 CONTINUE IRCHOI = 0 CHAIN1 = ' ' CALL LIRCHA(CHAIN1,0,IRCHOI) IF (IERR.NE.0) GOTO 99 IF (IRCHOI.EQ.0) GO TO 20 MOT4 = CHAIN1 * * SI ON A LU LE MOT TYPE * IF (MOT4.EQ.MOTYPE(1)) THEN CALL LIRCHA(JEROME,1,L1) IF (IERR.NE.0) GOTO 99 GOTO 10 ENDIF * * SI ON A LU LE MOT CONS (CAS OU MAILLAGE EST FOURNI) * IF (IPMAIL.NE.0) THEN IF (MOT4.EQ.MOTYPE(2)) THEN CALL LIRCHA(JECONS,1,LL1) IF (IERR.NE.0) GOTO 99 GO TO 10 ENDIF ENDIF * SI ON A LU LE SUPPORT DU CHAMP (CAS OU MODELE EST FOURNI) IF (IPMODL.NE.0.AND.IPLAC.EQ.0) THEN MOCHOY = CHAIN1 CALL PLACE(LISMOT,5,IPLAC,MOCHOY) IF (IPLAC.NE.0) GOTO 10 ENDIF IF (ISYNT2.NE.0) GOTO 10 * Syntaxe 1 : On lit paire MOT_Composante VALEUR_Flottant/Objet * ON A LU UNE COMPOSANTE * ON TESTE LE NOMBRE DE CARACTERES LUS IF (IRCHOI.GT.LOCOMP) THEN CALL ERREUR(536) GOTO 99 ENDIF MOCOMP=CHAIN1 * On recupere la valeur de la composante (REEL*8 ou POINTEURXXX) CALL LIRREE(RECOM,0,IRET2) IF (IERR.NE.0) GO TO 99 IF (IRET2.EQ.1) THEN MLMOT1.MOTS(**) = MOCOMP JG=MLREE1.PROG(/1)+1 SEGADJ MLREE1 MLREE1.PROG(JG)=RECOM ELSE CALL QUETYP(CAR,1,IRET1) IF (IERR.NE.0) GO TO 99 CALL LIROBJ(CAR,IPTRUC,1,IRET1) IF (IERR.NE.0) GO TO 99 CALL ACTOBJ(CAR,IPTRUC,1) IF (IERR.NE.0) GO TO 99 * * ON A LU UN OBJET DE TYPE AUTRE QU'UN FLOTTANT * MLMOT2.MOTS(**) = MOCOMP MLMOT3.MOTS(**) = CAR(1:4) MLMOTS.MOTS(**) = CAR(5:8) JG = MLENT2.LECT(/1)+1 SEGADJ,MLENT2 MLENT2.LECT(JG)=IPTRUC ENDIF GOTO 10 * 20 CONTINUE IPOI1 = 0 IF (L1.EQ.0) L1 = 1 * Par defaut : support 'NOEUD' IF (IPLAC.EQ.0) IPLAC=1 * * RECUPERATION DES ZONES ELEMENTAIRES DU MAILLAGE * IF (IPMAIL.NE.0)THEN MELEME=IPMAIL JG=LISOUS(/1) IF (JG.EQ.0) THEN JG=1 JGN=16 JGM=JG CALL oooprl(1) SEGINI,MLENT1,MLMOT4 CALL oooprl(0) MLENT1.LECT(1)=IPMAIL MLMOT4.MOTS(1)=JECONS ELSE JGN=16 JGM=JG CALL oooprl(1) SEGINI,MLENT1,MLMOT4 CALL oooprl(0) DO 22 I = 1, JG MLENT1.LECT(I)=LISOUS(I) MLMOT4.MOTS(I)=JECONS 22 CONTINUE ENDIF CALL MANUC4(MLENT1,MLMOT1,MLMOT2,MLMOT3,MLMOTS,MLREE1, & MLENT2,JEROME,L1,MLMOT4,IPOI1) * Suppression des segments SEGSUP,MLENT1,MLMOT4 ELSE CALL MANUC6(IPMODL,MLMOT1,MLMOT2,MLMOT3,MLMOTS,MLREE1, & MLENT2,JEROME,L1,IPLAC,IPOI1,itart) ENDIF IF (IERR.NE.0) GOTO 99 * Ecriture du CHAMP resultat : CALL ACTOBJ('MCHAML ',IPOI1,1) CALL ECROBJ('MCHAML ',IPOI1) * * Suppression des segments * 99 CONTINUE SEGSUP,MLMOTS,MLMOT1,MLMOT2,MLMOT3,MLREE1,MLENT2 END