fortran

C
C
C
      SUBROUTINE DSTPC(OUTF,INFL,TPIP,IE,DSTE,DST,DIRP,TFIL,COMMAN,
     /                 NCOPY,IRET,DSTRES)
	CHARACTER OUTF*(*),INFL*(*),TPIP*(*),DSTE(10)*4,DSTRES*4,
     /          DST*(*),DIRP*(*),TFIL*(*),COMMAN*(*)
      IRET = 0
      OUTF(IE-2:IE) = 'rs1'
      OPEN (31,FILE=OUTF)
      CLOSE (31,STATUS='DELETE')
      DO I = 1, 10
         OUTF(IE-3:IE) = DSTE(I)
         OPEN (31,FILE=OUTF,STATUS='UNKNOWN')
         CLOSE (31,STATUS='DELETE')
      ENDDO
      OPEN (31,FILE=INFL,STATUS='OLD')
      OUTF(IE-2:IE) = 'FRE'
      OPEN (32,FILE=OUTF(1:IE),STATUS='UNKNOWN')
      REWIND 31
      REWIND 32
	IF (NCOPY .EQ. 1) THEN
          DO I = 1, 1000000
             READ(31,300,END=39) TPIP
             WRITE(32,300) TPIP
          ENDDO
	ELSE
	    CALL ERRORS(1030)
	    CALL ANYKEY
	ENDIF
39    CLOSE (31)
      CLOSE (32)
      DIRP = DST
      ICI = 0
      DO I = 80, 1, -1
         IF (DST(I:I) .EQ. '/') ICI = ICI + 1
         IF (ICI .EQ. 2) THEN
             ICI = I
             DIRP = DST(1:ICI)
             DST  = DIRP
             EXIT
	       ENDIF
	    ENDDO
      CALL CHADIR(DIRP)
      CALL CONNEB(DIRP,'DSTPSPAR',0)
      OPEN (31,FILE=DIRP)
      WRITE(31,301,ERR=201) DST(1:ICI)
      DIRP = './resu/'
      CALL CONNEB(DIRP,TFIL(1:8),0)
      CALL FINDE(DIRP,IL,IRET)
      IF (DSTRES .EQ. '    ') THEN
          WRITE(31,302) DIRP(1:IL)
      ELSE
          WRITE(31,303) DIRP(1:IL),DIRP(1:IL)
      ENDIF
      CLOSE(31)
      GOTO 202
 201  CALL ERRORS(1027)
      CALL ANYKEY
      CLOSE(31)
      GOTO 30
C
C     ÔÚ΢»úµÄÍøÂç»·¾³ÖУ¬Åú´¦ÀíÖ´ÐÐPIPESTRESS³ÌÐò£»
C     ÒªÏÈÖ´ÐУºNET USE X: \\liusb\caps$\user\XXX\
C               XXXÊÇÓû§Ãû£¬ËùÓÐÓû§¶¼Òª×öͬÑù²Ù×÷¡£
C     »¹Òª½«£º1¡¢PIPESTRESSW£¬2¡¢WIBUKey.dll£¬3¡¢DSTPSRUN
C           Èý¸öÎļþ¿½µ½Óû§µÄÉÏÊöĿ¼ÖС£     
C
 202  COMMAN = 'pipestressw < DSTPSRUN'
      DIRP = DST(1:ICI)
      CALL ADDNUL(DIRP)
      CALL CHADIR(DIRP)
      RETURN
  30  IRET = -1
 300  FORMAT(A)
 301  FORMAT('PIPESTRESS 2010',/,'USER_PATH ',A)
 302  FORMAT('DATA ',A,'.FRE',/,'END')
 303  FORMAT('DATA ',A,'.FRE',/,
     /       'INPUT_RESTART ',A,'.rsm',/,'END')
	END
C
C
C
      SUBROUTINE CRTFLD(INF2,NODES,
CC¹¦ÄÜ: ÓÉDST/PIPESTRESS¼ÆËã½á¹ûÉú³ÉÎļþ£¬Î¢»ú°æ³ÌÐò¡£ÓëÔÚunixϵͳÉϲ»Í¬¡£
     /           NMODES,NLOAD,ILOD,NSUAN,OUTF,
     /           NODEA,XYZMS,DISLD,NLODS,STRSA,NSUANA,ACTSUA,
     /           FREQA,INNOD,NANA,NANCH,IUSR10)
      DIMENSION NODEA(2,*),XYZMS(NODES,3,*),
     /          DISLD(NODES,3,NLOAD),NLODS(NLOAD),STRSA(NODES,3,NLOAD),
     /          NSUANA(NSUAN,NLOAD),ACTSUA(NSUAN,6,NLOAD),NANA(NANCH),
     /          FREQA(NMODES),INNOD(2,*)
      CHARACTER INLIN*140,OUTF*(*)
C
      IEND = INDEX(OUTF,' ')-3
	OUTF(IEND:IEND+2) = 'prd'
	OPEN (INF2,FILE=OUTF)
      ILOD = 0
      MODE = 0
      DO I = 1, NODES
	DO K = 1, 3
      DO J = 1, NMODES
      XYZMS(I,K,J) = 0.
	ENDDO
	ENDDO
	ENDDO
C
C     READ IN A LINE AND GET THE TYPE OF RECORD. IRET < 0 CANNOT READ ANY MORE.
C
C     ITYP IS THE DATA TYPE BE FIND IN THE OUTPUT FILE!
C          = 1 LOADING CASE CARD BE FOUND.
C          = 2 RESPONSE CASE CARD BE FOUND
C
  2   CALL REDLIP(INF2,INLIN,ITYP,IRET)
      IF (IRET .LT. 0) GOTO 30
      IF (ITYP .EQ. 2) THEN
         CALL REDMDD(INF2,MODE,NODES,XYZMS,NODEA,FREQA)
      ELSE
          READ(INF2,104) INLIN
	ENDIF
      GOTO 2
  30  NMODES = MODE
      CLOSE (INF2)
      DO I = 1, NODES
	DO K = 1, 3
      DO J = 1, NLOAD
      STRSA(I,K,J) = 0.
      DISLD(I,K,J) = 0.
	ENDDO
	ENDDO
	ENDDO
      DO I = 1, NSUAN
      DO J = 1, NLOAD
      NSUANA(I,J) = 0
	DO K = 1, 6
      ACTSUA(I,K,J) = 0.
	ENDDO
	ENDDO
	ENDDO
      OUTF(IEND:IEND+2) = 'spp'
      CALL FILRCL(300,IUSEL)
C     IUSR10 ÔÚCAPS.COFµÄDEFL:=ÖеĵÚ10¸ö²ÎÊý¡£¶¨ÒåDSP/PIPESTRESSµÄ°æ±¾¡£
C                                              =0  3.7.0°æ, = 1  3.6.2°æ¡£
      IF (IUSR10 .EQ. 0) IUSEL = 300
	OPEN (INF2,FILE=OUTF,
     /     FORM='UNFORMATTED',ACCESS='DIRECT',RECL=IUSEL)
      CALL REDDST(INF2,NODES,NODEA,DISLD,STRSA,ILOD,NLODS,
     /            INNOD)
      CLOSE (INF2)
      OUTF(IEND:IEND+2) = 'app'
      CALL FILRCL(200,IUSEL)
      IF (IUSR10 .EQ. 0) IUSEL = 800
	OPEN (INF2,FILE=OUTF,
     /     FORM='UNFORMATTED',ACCESS='DIRECT',RECL=IUSEL)
      CALL REDDSS(INF2,NSUANA,NSUAN,ACTSUA,NANA,NANCH)
      CLOSE (INF2)
      CALL CRTBND(NMODES,NODES,NODEA,XYZMS,3)
      CALL CRTBND(NLOAD,NODES,NODEA,DISLD,3)
      CALL CRTBND(NLOAD,NODES,NODEA,STRSA,2)
100   FORMAT(3I8)
101   FORMAT(10(I8,1X))
102   FORMAT(6(E14.8,1X))
103   FORMAT(10(A4,2X))
104   FORMAT(A)
      END
C
C     ¶ÁÈësppÎļþÖеģ¬½ÚµãλÒÆ£¬½ÚµãÓ¦Á¦¡¢Ó¦Á¦±È¡£
C
      SUBROUTINE REDDST(INF2,NODES,NODEA,DISLD,STRSA,ILOD,NLODS,
     /                  INNOD)
      DIMENSION NODEA(2,NODES),INNOD(2,*),NLODS(*),
     /          DISLD(NODES,3,*),STRSA(NODES,3,*)
	CHARACTER*8 ELEF,ELET
	LOGICAL EXL1,EXL2
	REAL*8 PRS,ALLB,RF8(35),F8,BDIX,BDIY,BDIZ,EDIX,EDIY,EDIZ,
     /       EC,EH
	IR = 1
      READ(INF2,REC=IR,ERR=99) (II,I=1,40),ICODE,II,IVC,(II,I=1,45),
     /                          NLC,II,NTE,II,NEL,
     /                         (II,I=1,9),IO,II,II
	MLC = 50
 	IF (II .EQ. 1) MLC = 200
C
C     1983ÄêºóASME 2,3 ¼¶¹æ·¶ÓÃB1£¬B2¼ÆËãÓ¦Á¦£¬IBU=1¡£·ñÔò²»ÓÃIBU=0¡£
C
      IBU = 0
	IF (ICODE .EQ. 2. OR. ICODE .EQ. 3) THEN
	    IF (IVC .GT. 6) IBU = 1
	ENDIF
	IF (ICODE .EQ. 7) ICODE = 1
	IR  = 1 + 1 + MLC + NTE
	IRE = IR + NLC * NEL
	INC = 0
	ILC = 0
	FAT = 0.6894757/9.80665
 2    READ(INF2,REC=IR,ERR=99)  LC,II,IL3,(II,I=1,27),
     /                          ELEF,ELET,(II,I=1,6),PRS,F8,F8,F8,
     /                          EC,EH,ALLB,F8,EXL1,II1,(F8,I=1,4),
     /                          EXL2,II2,(F8,I=1,11),
     /                         (RF8(I),I=1,35),(F8,I=1,20),
     /                          BDIX,BDIY,BDIZ,(F8,I=1,20),
     /                          EDIX,EDIY,EDIZ,(F8,I=1,22),I149,II,II1
	ECEH = 1.
	BSIF = RF8(6)
	BSRA = RF8(7)
	BSTR = RF8(9)
	BB1  = RF8(10)
	BB2  = RF8(11)
	ESIF = RF8(15)
	ESRA = RF8(16)
	ESTR = RF8(18)
	EB1  = RF8(19)
	EB2  = RF8(20)
      IF (IBU .EQ. 0 .AND. ICODE .NE. 1) THEN
	    BB1 = 1.
	    BB2 = 1.
	    EB1 = 1.
	    EB2 = 1.
	ENDIF
	IF (ICODE .EQ. 1) THEN
	    BSRA = RF8(1)
	    BSTR = RF8(2)
	    ESRA = RF8(6)
	    ESTR = RF8(7)
C	    ECEH = EC / EH
	    BB1  = RF8(8)
	    BB2  = RF8(11)
	    EB1  = RF8(17)
	    EB2  = RF8(20)
	ENDIF
	IF (ELEF(1:3) .EQ. '   ') THEN
	    ELEF(1:1) = ELEF(4:4)
	    ELEF(2:4) = '   '
	ELSE IF (ELEF(1:2) .EQ. '  ') THEN
	    ELEF(1:2) = ELEF(3:4)
	    ELEF(3:4) = '  '
	ELSE IF (ELEF(1:1) .EQ. ' ') THEN
	    ELEF(1:3) = ELEF(2:4)
	    ELEF(4:4) = ' '
	ENDIF
	IF (ELET(1:3) .EQ. '   ') THEN
	    ELET(1:1) = ELET(4:4)
	    ELET(2:4) = '   '
	ELSE IF (ELET(1:2) .EQ. '  ') THEN
	    ELET(1:2) = ELET(3:4)
	    ELET(3:4) = '  '
	ELSE IF (ELET(1:1) .EQ. ' ') THEN
	    ELET(1:3) = ELET(2:4)
	    ELET(4:4) = ' '
	ENDIF
	BSTR = 0.
	ESTR = 0.
	SS   = 0.
	SE   = 0.
	IF (ABS(BSRA) .GT. 0.00000001) THEN
	    SS = ALLB*BSRA
	ELSE
	    BSRA = 0.
	ENDIF
	IF (ABS(ESRA) .GT. 0.00000001) THEN
	    SE = ALLB*ESRA
	ELSE
	    ESRA = 0.
	ENDIF
C      SS = PRS*BB1 + BSTR*BB2
C      SE = PRS*EB1 + ESTR*EB2
C	 SS = SS * ECEH
C	 SE = SE * ECEH
	IS = 0
	IF (LC .NE. ILC) THEN
	    ILOD = ILOD + 1
	    ILC  = LC
	    NLODS(ILOD) = IL3 
	ENDIF
	IF (ELEF(1:4) .EQ. '9999') THEN
	    ELEF = ELET
	ENDIF
      READ(ELEF,'(A4)') IT
      DO I = 1, INC
         IF (INNOD(2,I) .EQ. IT) THEN
             IS = INNOD(1,I)
             EXIT
         ENDIF
      ENDDO
      IF (IS .EQ. 0) THEN
          INC = INC + 1
          INNOD(2,INC) = IT
          DO I = 1, NODES
             IF (IT .EQ. NODEA(1,I)) THEN
                 IS = I
                 INNOD(1,INC) = I
                 GOTO 5
             ENDIF
          ENDDO
          INC = INC - 1
          GOTO 7
      ENDIF
 5    DISLD(IS,1,LC) = BDIX*0.0254
	DISLD(IS,2,LC) = BDIY*0.0254
	DISLD(IS,3,LC) = BDIZ*0.0254
	SS   = SS  * FAT
C	BF32 = BF32
	ALLB  = ALLB * FAT
C
C     ¶ÔÓÐÓ¢ÖÆÊäÈ뵥λµÄÌâÄ¿£¨IIN´óÓÚ0£©£¬ÖÐÐÔ½á¹ûÎļþ¼Ç¼²»¶Ô¡£
C                           ËùÒÔ£¬ÓÉÐíÓÃÓ¦Á¦ºÍÓ¦Á¦±È·´ÇóÓ¦Á¦Öµ¡£
C
	IF (ABS(SS)   .GT. ABS(STRSA(IS,1,LC)))
     /                       STRSA(IS,1,LC) = SS
	IF (ABS(BSRA) .GT. ABS(STRSA(IS,2,LC)))
     /                       STRSA(IS,2,LC) = BSRA
	IF (ABS(ALLB)  .GT. ABS(STRSA(IS,3,LC)))
     /                       STRSA(IS,3,LC) = ALLB
 7	IS = 0
      IF (ELET(1:4) .EQ. '9999') THEN
	    ELET = ELEF
	ENDIF
      READ(ELET,'(A4)') IT
      DO I = 1, INC
         IF (INNOD(2,I) .EQ. IT) THEN
             IS = INNOD(1,I)
             EXIT
         ENDIF
      ENDDO
      IF (IS .EQ. 0) THEN
          INC = INC + 1
          INNOD(2,INC) = IT
          DO I = 1, NODES
             IF (IT .EQ. NODEA(1,I)) THEN
                 IS = I
                 INNOD(1,INC) = I
                 GOTO 4
             ENDIF
          ENDDO
          INC = INC - 1
          GOTO 6
      ENDIF
 4    DISLD(IS,1,LC) = EDIX*0.0254
	DISLD(IS,2,LC) = EDIY*0.0254
	DISLD(IS,3,LC) = EDIZ*0.0254
	SE   = SE  * FAT
C
C     ¶ÔÓÐÓ¢ÖÆÊäÈ뵥λµÄÌâÄ¿£¨IIN´óÓÚ0£©£¬ÖÐÐÔ½á¹ûÎļþ¼Ç¼²»¶Ô¡£
C                           ËùÒÔ£¬ÓÐÐíÓÃÓ¦Á¦ºÍÓ¦Á¦±È·´ÇóÓ¦Á¦Öµ¡£
C
	IF (ABS(SE)   .GT. ABS(STRSA(IS,1,LC)))
     /                       STRSA(IS,1,LC) = SE
	IF (ABS(ESRA) .GT. ABS(STRSA(IS,2,LC)))
     /                       STRSA(IS,2,LC) = ESRA
	IF (ABS(ALLB)  .GT. ABS(STRSA(IS,3,LC)))
     /                       STRSA(IS,3,LC) = ALLB
  6   IR = IR + 1
	IF (IR .LT. IRE) GOTO 2
	RETURN
 99   RETURN
      END
C
C
C
      SUBROUTINE REDDSS(INF2,NSUANA,NSUAN,ACTSUA,NANA,NANCH)
      DIMENSION NSUANA(NSUAN,*),ACTSUA(NSUAN,6,*),NANA(NANCH)
	CHARACTER*4 ELEF
	REAL*8 BUFR(6),F8
	INTEGER IT
	IR = 1
      READ(INF2,REC=IR,ERR=99) (II,I=1,88),NLC,II,NTE,II,II,
     /                         (II,I=1,9),IO,II,II
	MLC = 50
	IF (II .EQ. 1) MLC = 200
	IR  = 1 + 1 + MLC
	IRE = IR + NLC * NTE
	INC = 0
	ILC = 0
	ITO = 0
 2    READ(INF2,REC=IR,ERR=99)  LC,(II,I=1,23),
     /                          ELEF,II,(F8,I=1,9),(BUFR(I),I=1,6)
	IF (ELEF(1:3) .EQ. '   ') THEN
c	    ELEF(1:1) = ELEF(4:4)
c	    ELEF(2:4) = '   '
	ELSE IF (ELEF(1:2) .EQ. '  ') THEN
c	    ELEF(1:2) = ELEF(3:4)
c	    ELEF(3:4) = '  '
	ELSE IF (ELEF(1:1) .EQ. ' ') THEN
c	    ELEF(1:3) = ELEF(2:4)
c	    ELEF(4:4) = ' '
	ENDIF
	IF (LC .NE. ILC) THEN
          IS  = 0
	    ILC = LC
	ENDIF
      READ(ELEF,103) IT
      ISANCH = 0
	DO I = 1, NANCH
	   IF (IT .EQ. NANA(I)) THEN
	       IF (IT .EQ. ITO) THEN
	           DO J = 1, 6
	              BUFR(J) = BUFR(J) + ACTSUA(IS,J,LC)
	           ENDDO
	           IS     = IS - 1
                 ISANCH = 1
	           EXIT
	       ENDIF
	   ENDIF
	ENDDO
      IS = IS + 1
      IF (ISANCH .EQ. 0) THEN
          DO I = 1, NSUAN
             IF (NSUANA(I,LC) .EQ. IT) THEN
                 IS = IS -1
                 EXIT
             ENDIF
          ENDDO
      ENDIF
      NSUANA(IS,LC) = IT
	ITO = IT
      IF (ABS(BUFR(1)) .GT. ABS(ACTSUA(IS,1,LC)))
     /                      ACTSUA(IS,1,LC) = BUFR(1)
	IF (ABS(BUFR(2)) .GT. ABS(ACTSUA(IS,2,LC)))
     /                      ACTSUA(IS,2,LC) = BUFR(2)
	IF (ABS(BUFR(3)) .GT. ABS(ACTSUA(IS,3,LC)))
     /                      ACTSUA(IS,3,LC) = BUFR(3)
	IF (ABS(BUFR(4)) .GT. ABS(ACTSUA(IS,4,LC)))
     /                      ACTSUA(IS,4,LC) = BUFR(4)
	IF (ABS(BUFR(5)) .GT. ABS(ACTSUA(IS,5,LC)))
     /                      ACTSUA(IS,5,LC) = BUFR(5)
	IF (ABS(BUFR(6)) .GT. ABS(ACTSUA(IS,6,LC)))
     /                      ACTSUA(IS,6,LC) = BUFR(6)
 7	IR = IR + 1
      IF (IR .LT. IRE) GOTO 2
	DO I = 1, IS
	DO J = 1, LC
	DO K = 1, 6
	   ACTSUA(I,K,J)=-0.4535924*ACTSUA(I,K,J)
	ENDDO
	DO K = 4, 6
	   ACTSUA(I,K,J)=ACTSUA(I,K,J)/3.2808399
	ENDDO
	ENDDO
	ENDDO
	RETURN
 99   RETURN
103   FORMAT(A4)
      END