Fortran编程技巧（持续更新）

if(...)then
  语句A
  goto 99
end if
if(...)then
  语句B
  goto 99
end if
语句C
99 语句D

out:do i=1,1
  if(...)then
    语句A
    exit out
  end if
  if(...)then
    语句B
    exit out
  end if
  语句C
end do out
语句D

!整数转换为字符串
pure function int2str(i) result(f_string) !摘自fpm源代码
    integer,intent(in)::i !i为要转换的整数
    character(len=str_int_len(i))::f_string !自动字符串 调用已有函数str_int_len 7.3Automatic objects《Mordern Fortran Explained 2018》P120
    
    write(f_string,"(i0)")i !f_string长度必须明确
end function int2str
!> Returns the length of the string representation of 'i'
pure integer function str_int_len(i) result(sz) !摘自fpm源代码
    integer, intent(in) :: i
    integer, parameter :: MAX_STR = 255 !字符串最大长度
    character(MAX_STR) :: s
    ! If 's' is too short (MAX_STR too small), Fortran will abort with:
    ! "Fortran runtime error: End of record"
    write(s, '(i0)') i !左对齐 F202X标准才支持s为递延字符串
    sz = len_trim(s) !删除尾部空格后的字符串长度
end function str_int_len

pure function real2str(MXS,ld) result(res) !浮点数转换为字符串 调用str_int_len、int2str函数
    real(real64),intent(in)::MXS !浮点数
    integer,intent(in)::ld !小数保留位数
    character(len=:),allocatable::res,ft !递延长度字符串
    character(len=255)::str
    
    select case(ld)
        case(0) !浮点数四舍五入取整
            res=int2str(nint(MXS)) !不需要ft
        case(1:4) !小数保留1-4位
            ft="(f"//int2str(str_int_len(int(MSX))+ld+1)//"."//int2str(ld)//")" !"(fX.Y)" 浮点数格式 Y为小数点保留位数 X为总字符串长度(整数部分+小数点+小数部分)
            write(str,ft)MXS !浮点数转换为字符串 左对齐 只能用str而不能用res F202X标准才支持str为递延字符串
            res=trim(str) !删除尾部空格
            deallocate(ft) !释放递延字符串内存 不能放在函数尾部 否则浮点数四舍五入取整无法计算
        case default
            error stop "小数保留位数超出范围！"
    end select
end function real2str

FUNCTION C_to_F_string(c_string_pointer) RESULT(f_string) !C字符串指针转换Fortran字符串
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER, C_CHAR, C_NULL_CHAR
        type(C_PTR), INTENT(IN) :: c_string_pointer !C字符串指针
        CHARACTER(LEN=:), ALLOCATABLE :: f_string !延迟长度字符串
        CHARACTER(KIND=C_CHAR), DIMENSION(:), POINTER :: char_array_pointer => NULL() !Fortran字符数组指针
        CHARACTER(LEN=255) :: aux_string
        INTEGER :: i, length=0

        CALL C_F_POINTER(c_string_pointer, char_array_pointer, [255]) !C字符串指针转换为Fortran字符数组指针

        IF (.NOT.ASSOCIATED(char_array_pointer)) THEN !char_array_pointer为空指针
            ALLOCATE(CHARACTER(LEN=4)::f_string)
            f_string="NULL"
            return
        END IF

        aux_string=" "

        DO i=1,255
            IF (char_array_pointer(i)==c_null_char) THEN !达到字符串尾部
                length=i-1
                EXIT
            END IF

            aux_string(i:i)=char_array_pointer(i) !逐个元素复制字符
        END DO

        ALLOCATE(CHARACTER(LEN=length)::f_string)
        f_string=aux_string(1:length)
END FUNCTION C_to_F_string

impure function GetPassword(PasswordLen,IsDay) !获得动态密码及长度
    integer,intent(out)::PasswordLen
    logical,intent(in),optional::IsDay !动态密码是否日变化
    character(len=:),allocatable::GetPassword !递延长度字符串
    character(8)  :: date,temp !CCYYMMDD
    character(10) :: time !HHMMSS.SSS
    
    call date_and_time(date,time) !返回当前日期与时间
    temp=date(3:8)//time(1:2) !界面进入原始密码 为与时间有关的动态密码YYMMDDHH 两位年月日时
    
    if(present(IsDay))then
        if(IsDay)temp=date(1:8) !界面进入密码 为与日期有关的动态密码CCYYMMDD 四位年月日
    end if
    
    GetPassword="Wx"
    GetPassword=GetPassword//temp(2:8)//temp(1:1) !加工后密码
    PasswordLen=len(GetPassword) !输出密码字符串长度
end function

Any(a(:)==b) !T相等F不相等

FindLoc(a(:),b)==[0] !F相等T不相等

character(:),allocatable::a,b
a="A"
b="A " !A后面加一个空格
write(*,*)a==b !你以为打印F 其实打印T
write(*,*)(a==b .AND. (len(a)==len(b))) !打印F

program fcode_cn
  integer :: wk
  read(*,*) wk
  select case(wk)
  case (1)
    write(*,*) "看电影"
  case (2)
    write(*,*) "看书"
  case (3)
    write(*,*) "聚会"
  case (4)
    write(*,*) "野营"
  case (5,6)
    write(*,*) "旅行"
  case (7)
    write(*,*) "休息"
  end select
end program fcode_cn

program fcode_cn
  character(len=6) , parameter :: ACT(*) = &
    [character(len=6)::"看电影","看书","聚会","野营","旅行","旅行","休息"]
  integer :: wk
  read(*,*) wk
  write(*,*) ACT(wk)
end program fcode_cn

  do i = 1 , size(ACT)
    write(*,*) ACT(i)
  end do