macro.f90

边界元程序,供力学工作者参考,希望对大家有所帮助

        SUBROUTINE ReadMacro
!........
!       模块功能
!           读入并编辑宏命令.
!........
        USE CtrlData
        USE MacroData
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        CHARACTER strng * 90, mwork * 15
        IF( nerrc .GT. 0 ) RETURN
!.......初始化数组.
        nmacr = 0
        iacia = ICHAR( 'A' )
        iaciz = ICHAR( 'Z' )
        istep = ICHAR( 'a' ) - ICHAR( 'A' )
!.......寻找宏命令入口 "macro".
        label = 0
        DO WHILE( label .EQ. 0 )
          ibegn = 0
          READ( 13, '( a90 )', END = 200 ) strng
!.........把所有的','改为' '
          DO istrg = 1, 90
            IF( strng( istrg:istrg ) .EQ. ',' )                                &
                strng( istrg:istrg ) = ' '
          END DO
!.........先删除开头部分的空格
          DO istrg = 1, 90
            IF( ibegn .EQ. 0 ) THEN
              IF( strng( istrg:istrg ) .NE. ' ' ) ibegn = istrg
            END IF
            IF( ibegn .GT. 0 ) THEN
              locat = istrg - ibegn + 1
              strng( locat:locat ) = strng( istrg:istrg )
            END IF
          END DO
!.........宏命令的关键词是否'macro'
          DO istrg = 1, 5
            iacii = ICHAR( strng( istrg:istrg ) )
            IF( iacii .GE. iacia .AND. iacii .LE. iaciz )                      &
             strng( istrg:istrg ) = CHAR( iacii + istep )
          END DO
          IF( strng( 1:5 ) .EQ. 'macro' ) label = 1
        END DO
!.......读入宏命令.
        DO WHILE( label .EQ. 1 )
          READ( 13, '( a90 )', END = 400 ) strng
          CALL ReLocate( strng, nerrc )
          IF( nerrc .GT. 0 ) RETURN
          mwork = strng( 1:15 )
          jmacr = 0
          DO imacr = 1, mcmds
            IF( jmacr .EQ. 0 ) THEN
              IF( macro( imacr ) .EQ. mwork ) jmacr = imacr
            END IF
          END DO
          IF( mwork .NE. '               ' ) THEN
            IF( jmacr .EQ. 0 ) THEN
!.............无效的宏命令.
              WRITE( 12, 2000 ) mwork
              nerrc = 3002
              label = 0
            ELSE IF( jmacr .EQ. mcmds ) THEN
!.............宏命令结束.
              label = 0
            ELSE IF( jmacr .NE. mcmds - 1 ) THEN
!.............输入的宏命令有效.
              nmacr = nmacr + 1
              IF( nmacr .GT. mmacr ) THEN
                WRITE( 12, 2200 ) mmacr, nmacr
                nerrc = 3003
                RETURN
              END IF
              IF( jmacr .EQ. 46 ) THEN
!...............宏命令accel需要增加四条宏命令stiffen, cmass, damp和force.
                DO imacr = 21, 24
                  IF( imacr .NE. 23 .OR. lsavc( 3 ) .NE. 0 ) THEN
                    lmacr( 1, nmacr ) = imacr
                    pmacr( 2, nmacr ) = 0.0D0
                    pmacr( 3, nmacr ) = 0.0D0
                    pmacr( 4, nmacr ) = 0.0D0
                    pmacr( 5, nmacr ) = 0.0D0
                    IF( imacr .EQ. 21 ) pmacr( 1, nmacr ) = 5
                    IF( imacr .EQ. 24 ) lmacr( 1, nmacr ) = 25
                    nmacr = nmacr + 1
                  END IF
                END DO
              END IF
              lmacr( 1, nmacr ) = jmacr
              mwork = strng( 16:30 )
              READ( mwork, * ) pmacr( 1, nmacr )
              mwork = strng( 31:45 )
              READ( mwork, * ) pmacr( 2, nmacr )
              mwork = strng( 46:60 )
              READ( mwork, * ) pmacr( 3, nmacr )
              mwork = strng( 61:75 )
              READ( mwork, * ) pmacr( 4, nmacr )
              mwork = strng( 76:90 )
              READ( mwork, * ) pmacr( 5, nmacr )
              CALL PreExecute
            END IF
          END IF
        END DO
        CALL Compiler
        IF( nerrc .GT. 0 ) RETURN
        IF( nprnc .NE. 0 ) THEN
          WRITE( 12, 2600 )
          DO imacr = 1, nmacr
            ncomm = lmacr( 1, imacr )
            IF( ncomm .NE. 0 ) THEN
              WRITE( 12, '(1x, A15\)' ) macro( ncomm )
              DO ipara = 1, 5
                jpara = pmacr( ipara, imacr ) + 0.5D0
                dskip = DABS( pmacr( ipara, imacr ) - jpara )
                dleng = DABS( pmacr( ipara, imacr ) )
                IF( dleng .GT. 1.0D-12 ) dskip = dskip / dleng
                IF( dskip .LT. 1.0D-8 ) THEN
                  WRITE( 12, '(I15\)' ) jpara
                ELSE
                  WRITE( 12, '(F15.5\)' ) pmacr( ipara, imacr )
                END IF
              END DO
              WRITE( 12, * )
            END IF
          END DO
        END IF
        RETURN
!.......没有宏命令"macro"
200     WRITE( 12, 1800 )
        nerrc = 3001
        RETURN
!.......没有宏命令"endmacro"
400     WRITE( 12, 2400 )
        nerrc = 3004
        RETURN
!.......format block.
1800    FORMAT( 2x, '错误: 缺控制宏命令macro' )
2000    FORMAT( 2x, '错误: 无效的宏命令', A15 )
2200    FORMAT( 2x, '错误: 宏命令总数超界' /                                   &
                2x, '      目前最多允许宏命令数目为:', I5 /                    &
                2x, '      您至少需要的许宏命令数目为:', I5 )
2400    FORMAT( 2x, '错误: 缺控制宏命令endmacro' )
2600    FORMAT( //20x, '= = = = = 宏 命 令 = = = = =' // 1x, '宏命令',         &
                  18x, '参数一', 9x, '参数二', 9x, '参数三',                   &
                   9x, '参数四', 9x, '参数五' )
        END

        SUBROUTINE ReLocate( strng, nerrc )
!.......
!       模块功能
!           命令行编译重定位.
!.......
        CHARACTER strng * 90, strsg( 6 ) * 15
        ismla = ichar( 'a' )
        ichpa = ichar( 'A' )
        ichpz = ichar( 'Z' )
        istep = ismla - ichpa
!.......初始化数组.
        DO idigt = 1, 6
          DO istrg = 1, 15
            strsg( idigt )( istrg:istrg ) = ' '
          END DO
        END DO
!.......宏命令被分为六段.
        nbegs = 1
        DO idigt = 1, 6
!.........删除空格.
          IF( strsg( 1 ) .NE. 'rem            ' ) THEN
            nends = 0
            DO istrg = nbegs, 90
              IF( nends .EQ. 0 ) THEN
                IF( strng( istrg:istrg ) .NE. ' ' ) nends = istrg
              END IF
            END DO
            IF( nends .EQ. 0 ) nends = 91
!...........保存每一控制段.
            nbegs = nends
            nends = 0
            DO istrg = nbegs, 90
              IF( nends .EQ. 0 ) THEN
                locat = istrg - nbegs + 1
                IF( strng( istrg:istrg ) .EQ. ' ' ) THEN
                  nends = istrg
                ELSE
                  IF( locat .GT. 15 ) THEN
                    WRITE( 12, 2000 ) strng
                    nerrc = 3005
                    RETURN
                  END IF
                  strsg( idigt )( locat:locat ) = strng( istrg:istrg )
                END IF
              END IF
            END DO
            IF( nends .EQ. 0 ) nends = 91
            nbegs = nends
!...........改大写字母为小写字母.
            DO istrg = 1, 15
              icurs = ichar( strsg( idigt )( istrg:istrg ) )
              IF( icurs .GE. ichpa .AND. icurs .LE. ichpz )                    &
              strsg( idigt )( istrg:istrg ) = CHAR( icurs + istep )
            END DO
          END IF
        END DO
!.......重新保存各控制段信息.
        DO idigt = 2, 6
          IF( strsg( idigt ) .EQ. '               ' )                          &
              strsg( idigt ) = '0              '
        END DO
        DO idigt = 1, 6
          DO istrg = 1, 15
            locat = ( idigt - 1 ) * 15 + istrg
            strng( locat:locat ) = strsg( idigt )( istrg:istrg )
          END DO
        END DO
2000    FORMAT( 2x, '错误: 无效的宏命令行' / 8x, A90 )
        RETURN
        END

        SUBROUTINE Compiler
!........
!       模块功能
!           编译宏命令.
!........
        USE CtrlData
        USE MacroData
        IMPLICIT DOUBLE PRECISION( a-h, o-z )
        PARAMETER( maxloopdeep = 200 )
        DIMENSION ldeep( 2, maxloopdeep )
!.......首先编译宏命令"loop".
        kdeep = 0
        DO imacr = 1, nmacr
          IF( lmacr( 1, imacr ) .EQ. 1 ) THEN
!...........宏命令"loop"
            kdeep = kdeep + 1
            IF( DABS( pmacr( 3, imacr ) ) .LE. 1.0D-8 )                        &
                      pmacr( 3, imacr ) = 1.0D0
            IF( kdeep .GT. maxloopdeep ) THEN
!.............loop圈套太多.
              WRITE( 12, 2000 )
              nerrc = 3006
              RETURN
            END IF
            ldeep( 1, kdeep ) = imacr
          ELSE IF( lmacr( 1, imacr ) .EQ. 2 ) THEN
!...........宏命令endloop.
            IF( kdeep .LE. 0 ) THEN
!.............宏命令loop和endloop不匹配.
              WRITE( 12, 2200 ) imacr
              nerrc = 3006
              RETURN
            END IF
            ldeep( 2, kdeep ) = imacr
            lmacr( 2, imacr ) = ldeep( 1, kdeep ) + 1
            lmacr( 3, ldeep( 1, kdeep ) ) = imacr
            kdeep = kdeep - 1
          ELSE IF( lmacr( 1, imacr ) .EQ. 3 ) THEN
!...........宏命令"tolen".
            IF( kdeep .LT. 1 ) THEN
              WRITE( 12, 2400 )
              nerrc = 3007
              RETURN
            END IF
          ELSE IF( lmacr( 1, imacr ) .EQ. 4 ) THEN
!...........宏命令"nottolen".
            IF( kdeep .LT. 1 ) THEN
              WRITE( 12, 2600 )
              nerrc = 3008
              RETURN
            END IF
          END IF
        END DO
!.......宏命令"endloop"和"loop"不匹配.
        IF( kdeep .GT. 0 ) THEN
          WRITE( 12, 2800 )
          nerrc = 3008
          RETURN
        END IF
!.......编译"tolen"和"nottolen".
        kdeep = 0
        DO imacr = 1, nmacr
          IF( lmacr( 1, imacr ) .EQ. 1 ) THEN
            kdeep = kdeep + 1
            ldeep( 1, kdeep ) = imacr
            ldeep( 2, kdeep ) = lmacr( 3, imacr )
          ELSE IF( lmacr( 1, imacr ) .EQ. 2 ) THEN
            kdeep = kdeep - 1
          ELSE IF( lmacr( 1, imacr ) .EQ. 3 ) THEN
            lmacr( 2, imacr ) = ldeep( 2, kdeep ) + 1
          ELSE IF( lmacr( 1, imacr ) .EQ. 4 ) THEN
            lmacr( 2, imacr ) = ldeep( 2, kdeep ) + 1
          END IF
        END DO
!.......设定下一步地址.
        DO imacr = 1, nmacr
          IF( lmacr( 2, imacr ) .EQ. 0 ) lmacr( 2, imacr ) = imacr + 1
        END DO
!........
        DO imacr = 1, nmacr
          ncomm = lmacr( 1, imacr )
!          IF( ncomm .EQ. 22 .AND. ntypc .EQ. 0 ) nerrc = 7563
!          IF( ncomm .EQ. 23 .AND. ntypc .EQ. 0 ) nerrc = 7563
!          IF( ncomm .EQ. 42 .AND. ntypc .EQ. 0 ) nerrc = 7563
!          IF( ncomm .EQ. 43 .AND. ntypc .NE. 2 ) nerrc = 7563
!          IF( ncomm .EQ. 44 .AND. ntypc .NE. 2 ) nerrc = 7563
!          IF( ncomm .EQ. 45 .AND. ntypc .EQ. 0 ) nerrc = 7563
!          IF( ncomm .EQ. 46 .AND. ntypc .NE. 2 ) nerrc = 7563
!          IF( ncomm .EQ. 48 .AND. ntypc .NE. 2 ) nerrc = 7563
!          IF( ncomm .EQ. 62 .AND. ntypc .NE. 2 ) nerrc = 7563
!          IF( ncomm .EQ. 63 .AND. ntypc .NE. 2 ) nerrc = 7563
!          IF( ncomm .EQ. 84 .AND. ntypc .NE. 2 ) nerrc = 7563
!          IF( ncomm .EQ. 85 .AND. ntypc .NE. 2 ) nerrc = 7563
!          IF( ncomm .EQ. 86 .AND. ntypc .NE. 2 ) nerrc = 7563
        END DO
!.......附加结尾标识.
        nmacr = nmacr + 1
        lmacr( 1, nmacr ) = 0
        lmacr( 2, nmacr ) = 0
        lmacr( 3, nmacr ) = 0
        pmacr( 1, nmacr ) = 0
        pmacr( 2, nmacr ) = 0
        pmacr( 3, nmacr ) = 0
        pmacr( 4, nmacr ) = 0
        pmacr( 5, nmacr ) = 0
2000    FORMAT( 2x, '错误: 循环圈套太多' )
2200    FORMAT( 2x, '错误: endloop无匹配的宏命令loop' )
2400    FORMAT( 2x, '错误: tolen无匹配的宏命令loop' )
2600    FORMAT( 2x, '错误: nottolen无匹配的宏命令loop' )
2800    FORMAT( 2x, '错误: loop无匹配的宏命令endloop' )
        RETURN
        END

        SUBROUTINE PreExecute
        USE MacroData
        kcmmd = lmacr( 1, nmacr )
        para1 = pmacr( 1, nmacr )
        para2 = pmacr( 2, nmacr )
        para3 = pmacr( 3, nmacr )
        para4 = pmacr( 4, nmacr )
        para5 = pmacr( 5, nmacr )
        kpar1 = pmacr( 1, nmacr ) + 0.5D0
        kpar2 = pmacr( 2, nmacr ) + 0.5D0
        kpar3 = pmacr( 3, nmacr ) + 0.5D0
        kpar4 = pmacr( 4, nmacr ) + 0.5D0
        kpar5 = pmacr( 5, nmacr ) + 0.5D0
        IF( kcmmd .EQ. 65 ) CALL InitHis( kpar1, kpar2, kpar3 )
        RETURN
        END