*Fortran → 使いにくい場合は [[C]], [[C++]], [[D]], [[Go]], [[Haskell]], [[F#>F Sharp]], [[C#>C Sharp]], [[Visual Basic]], [[Java]], [[Python]], [[Ruby]], [[Julia]] などを使用して Fortran で記述されたライブラリを呼び出す [#pbb06ff1]
#ref(http://upload.wikimedia.org/wikipedia/commons/0/07/Fortran_acs_cover.jpeg,right,around,nolink,203x260,Fortran)
&color(White,#5F2F2F){ ''◆CONTENTS◆'' };&br;
#contents
*Summary [#o355751c]
-[[Wikipedia.ja:FORTRAN]]
-[[Fortran Wiki:http://fortranwiki.org/]]
--[[Fortran 2008 status:http://fortranwiki.org/fortran/show/Fortran+2008+status]]
--[[Fortran 2003 status:http://fortranwiki.org/fortran/show/Fortran+2003+status]]
-[[Fortran入門:http://www.nag-j.co.jp/fortran/]]
-[[Fortran 2003入門:http://www.nag-j.co.jp/fortran/fortran2003/]]
-[[Getting Started with the Intel® Fortran Composer XE 2013 SP1 for Linux* OS:http://nf.nci.org.au/facilities/software/intel-ct/14.0.080/Documentation/en_US/get_started_lf.htm]]
-[[インテル® Fortran Composer XE 2013 Linux* 版入門:http://nf.nci.org.au/facilities/software/intel-ct/13.5.192/Documentation/ja_JP/get_started_lf.htm]]
-[[User and Reference Guide for the Intel® Fortran Compiler 14.0:http://nf.nci.org.au/facilities/software/intel-ct/14.0.080/Documentation/en_US/compiler_f/main_for/index.htm]]
-[[インテル® Fortran コンパイラー XE 13.1 ユーザー・リファレンス・ガイド:http://nf.nci.org.au/facilities/software/intel-ct/13.5.192/Documentation/ja_JP/compiler_f/main_for/index.htm]]
-http://pic.dhe.ibm.com/infocenter/lnxpcomp/v121v141/index.jsp
-[[Cray Fortran Reference Manual:http://docs.cray.com/books/S-3901-81/]]
-http://qiita.com/tags/fortran
-[[Fortran2003のページ:http://www.geocities.jp/wjtcx143/fortran.html]]
-[[Tagged "Fortran2003" | ドウジンテイスウ.log:http://sage-t.tumblr.com/tagged/Fortran2003]]
-[[fortran66のブログ:http://fortran66.hatenablog.com/]]
-[[fortran66の日記:http://d.hatena.ne.jp/fortran66/]]
-[[Fortran日記:http://fortran.cscblog.jp/]]
-[[なんとなく始めたブログ: fortran:http://sak12.blogspot.jp/search/label/fortran]]
-[[Fortrantips:http://pmt.sakura.ne.jp/wiki/index.php?title=Fortrantips]]
-[http://ig.hateblo.jp/archive/category/fortran "fortran" - 記事一覧 - いぐにすさんのメモログ]
-[[Fortranで水理計算:http://fortran.godo-tys.jp/dokuwiki/fortran]]
-https://github.com/OpenFortranProject
-[[Fortran Archives - Moonmile Solutions Blog:http://www.moonmile.net/blog/archives/category/dev/fortran]]
-http://qiita.com/tags/fortran
-[[FortranからPythonへ:http://www.slideshare.net/shibukawa/fortranpython-presentation]]
-[[2.2 Fortran90/95入門 後半:http://exp.cs.kobe-u.ac.jp/wiki/comp_practice/index.php?2.2%20Fortran90%2F95%C6%FE%CC%E7%20%B8%E5%C8%BE]]
-[[Fortran90/95での引数の値渡し (Pass by value):http://sgks.blogspot.jp/2008/02/fortran9095-pass-by-value.html]]
-http://gcc.gnu.org/onlinedocs/gfortran/Interoperable-Subroutines-and-Functions.html
-http://software.intel.com/en-us/forums/topic/270769
-http://publib.boulder.ibm.com/infocenter/comphelp/v8v101/index.jsp?topic=%2Fcom.ibm.xlf101a.doc%2Fxlflr%2Finterop-iso-c-binding-module.htm
-http://be.nucl.ap.titech.ac.jp/~koba/cgi-bin/moin.cgi/FORTRAN
-[[高速化プログラミング:http://fast-programming.aglk.net/]]
-[[Fortran 覚書:http://www.gcxx.jp/memo/?fortran]]
-[[Fortranスマートプログラミング:http://www.ile.osaka-u.ac.jp/research/cmp/text.html]] (PDF)
-[[Fortran 90/95 入門①:http://www.hucc.hokudai.ac.jp/~a10019/kosyu/pdf2/Fortran_1.pdf]] (PDF)
-[[Fortran 90/95 入門②:http://www.hucc.hokudai.ac.jp/~a10019/kosyu/pdf2/Fortran_2.pdf]] (PDF)
-[[データ解析のためのFortran90/95:http://web.agr.ehime-u.ac.jp/~kishou/Lecture/atmosphere/atmo06.htm]]
-[[Fortran90プログラミング:http://www7b.biglobe.ne.jp/~fortran/]]
-[[Fortran エラー処理で文番号を使わない方法 :http://seismon.blog85.fc2.com/blog-entry-90.html]]
-[[Fortran90で構造解析をしよう！:http://www.rcs.arch.t.u-tokyo.ac.jp/kusuhara/tips/linux/fortran.html]]
-[[Fortranでの配列の要素へのアクセス順序について:http://d.hatena.ne.jp/aldente39/20120209/1328800255]]
-[[MinGW Fortran でプログラミング Excelで使用:http://pub.ne.jp/TakeA/?entry_id=4584618]]
-[[計算機に関する雑多なTips:http://daweb.ism.ac.jp/~saitohm/top/_tRlEvpW.html]]
-[http://lochtext.hatenablog.com/entry/20140606/1402058404 FortranをCっぽく書く]
-[[Fortran 90 with Excel – gfortran example:http://sukhbinder.wordpress.com/2010/07/20/fortran-90-with-excel-gfortran-example/]]
-[[using gfortran to call windows api functions:http://compgroups.net/comp.lang.fortran/using-gfortran-to-call-windows-api-function/226148]]
-[[Bug 34112 - Add $!DEC ATTRIBUTE support for 32bit Windows' STDCALL:http://gcc.gnu.org/bugzilla/show_bug.cgi?id=34112]]
-[[gfortran, DLL, underscore:http://stackoverflow.com/questions/1985819/gfortran-dll-underscore]]
-http://gcc.gnu.org/onlinedocs/gfortran/GNU-Fortran-Compiler-Directives.html
-http://gcc.gnu.org/wiki/Coarray
**処理系 [#xfad745a]
-[[GNU Fortran (gfortran):http://gcc.gnu.org/wiki/GFortran]]
--[https://gcc.gnu.org/wiki/GFortranBinaries GFortranBinaries - GCC Wiki]
--[[TS29113Status - GCC Wiki:http://gcc.gnu.org/wiki/TS29113Status]]
--[[Fortran2008Status - GCC Wiki:http://gcc.gnu.org/wiki/Fortran2008Status]]
--[[Fortran2003Status - GCC Wiki:http://gcc.gnu.org/wiki/Fortran2003Status]]
--http://gcc.gnu.org/onlinedocs/gfortran/Fortran-2003-and-2008-status.html
--Windows では [[MinGW]], [[Cygwin]], [[Strawberry Perl:http://strawberryperl.com/]] などに収録されています．
--OS X では [[High Performance Computing for Mac OS X:http://hpc.sourceforge.net/]] からバイナリが取得できます．
--http://gfortran.com/ gfortran daily builds
-[[Intel Fortran Compiler (ifort):http://software.intel.com/en-us/fortran-compilers]]
--http://software.intel.com/en-us/non-commercial-software-development (Linux, 非商用での使用のみ可)
--[[Ubuntu14.04 64bit にIntel® Parallel Studio XE 2013 for Linuxのインストール:http://d.hatena.ne.jp/cmphys/20140501/1398925683]]
--[[Fortran (Intel Parallel Studio) のインストール:http://pen.agbi.tsukuba.ac.jp/~RStiger/hiki2/?Fortran+%28Intel+Parallel+Studio+XE%29+%A4%CE%A5%A4%A5%F3%A5%B9%A5%C8]]
--[[ifort で最近良く使うコンパイルオプション:http://naturesflyers.blogspot.jp/2013/08/ifort.html]]
**IDE・エディタ [#xe73a6d2]
http://fortranwiki.org/fortran/show/Source+code+editors を参照．~
***フリーソフトウェア (オープンソースソフトウェア) [#yb3ceb92]
-[[Eclipse]]
--[[Photran:http://www.eclipse.org/photran/]]
-[[Code::Blocks:http://www.codeblocks.org/]]
--[[Code::Blocks IDE for Fortran:http://darmar.vgtu.lt/]]
-[[Emacs]]
-[[Vim]]
-[[Notepad++]]
-[[サクラエディタ]]
--[http://sakura.qp.land.to/?Customize%2F%C5%EA%B9%C6%2F39 FORTRAN 強調キーワード・カラー定義]
*Fortran 2008 の使い方 [#r3bbac60]
**使用可能な拡張子 [#d9d770b5]
GNU Fortran の場合は拡張子に .f90, .f95, .f03, .f08, .F90, .F95, .F03, .F08 などが使用できます．~
GNU Fortran と Intel Fortran Compiler を両方使用してプログラムを作成する場合は拡張子は .f90 または .F90 を使用することをおすめします．~
|自由形式 (free form)|.f90, .f95, .f03, .f08, .F90, .F95, .F03, .F08|
|固定形式 (fixed form)|.f, .for, .fpp, .ftn, .F, .FOR, .FPP, .FTN|
-http://gcc.gnu.org/onlinedocs/gfortran/GNU-Fortran-and-GCC.html
-http://nf.nci.org.au/facilities/software/intel-ct/13.5.192/Documentation/ja_JP/compiler_f/main_for/GUID-75F416C4-ADD7-41D0-AEFE-E61F50C04A82.htm
**標準出力 に "Hello World" を出力 [#x79017be]
----
-helloworld.f90
----
program hello_world
implicit none
print '(*(g0))', "Hello World"
end program hello_world
----
program hello_world
use, intrinsic :: iso_fortran_env
implicit none
write(unit=output_unit, fmt='(*(g0))') "Hello World"
end program hello_world
----
module c_stdio
use, intrinsic :: iso_c_binding
implicit none
private
public :: puts
interface
subroutine puts(s) bind(c, name='puts')
import
character(kind=c_char), intent(in) :: s
end subroutine puts
end interface
end module c_stdio
program hello_world
use, intrinsic :: iso_c_binding
use c_stdio
implicit none
call puts("Hello World" // c_null_char)
end program hello_world
----
GNU Fortran 4.8.1 で動作確認しています．~
データの出力は print 文や write 文で行います．~
g0 編集記述子は print 文や write 文で整数や文字列などの任意の組み込み型に対して使用できます．~
print 文や write 文でフォーマットに * のみを指定して出力した場合は gfortran と ifort で出力フォーマットが異なる場合があるかもしれません．~
gfortran と ifort で出力フォーマットが異なる場合は書式指定してください．~
C の puts 関数を呼び出して出力することもできます．~
Fortran の文字列は null 終端文字列ではないので C の関数に文字列を渡す場合は c_null_char を末尾に追加して渡す必要があります．~
$ gfortran -Wall -Ofast -march=native -std=f2008 -static -o helloworld helloworld.f90
$ ./helloworld
MinGW の gfortran でビルドしたバイナリで
-Windows PowerShell から実行するとなにも表示されない
-コマンド プロンプトから実行するとアプリケーションエラーが発生する
といった現象が発生する場合は
$ gfortran -Wall -Ofast -march=native -std=f2008 -static -o helloworld helloworld.f90
のように -static オプションを追加してビルドすれば OK です．~
**MessageBox に "Hello World" を出力 [#i3cc6f7f]
----
-helloworldmessagebox.f90
----
module windows_api
use, intrinsic :: iso_c_binding
implicit none
private
public :: MessageBoxA
interface
subroutine MessageBoxA(hWnd, lpText, lpCaption, uType) bind(c, name='MessageBoxA')
import
!gcc$ attributes stdcall :: MessageBoxA
type(c_ptr), value :: hWnd
character(kind=c_char), intent(in) :: lpText
character(kind=c_char), intent(in) :: lpCaption
integer(kind=c_int), value :: uType
end subroutine MessageBoxA
end interface
end module windows_api
program hello_world_message_box_a
use, intrinsic :: iso_c_binding
use windows_api
implicit none
character(len=*, kind=c_char), parameter :: msg = "Hello World" // c_null_char
call MessageBoxA(c_null_ptr, msg, msg, 0)
end program hello_world_message_box_a
----
module c_string
use, intrinsic :: iso_c_binding
implicit none
private
public :: memset
interface
subroutine memset(buf, ch, n) bind(c, name='memset')
import
type(c_ptr), value :: buf
integer(kind=c_int), value :: ch
integer(kind=c_size_t), value :: n
end subroutine memset
end interface
end module c_string
module windows_api
use, intrinsic :: iso_c_binding
implicit none
private
public :: MessageBoxW, MultiByteToWideChar
interface
subroutine MessageBoxW(hWnd, lpText, lpCaption, uType) bind(c, name='MessageBoxW')
import
!gcc$ attributes stdcall :: MessageBoxW
type(c_ptr), value :: hWnd
type(c_ptr), value :: lpText
type(c_ptr), value :: lpCaption
integer(kind=c_int), value :: uType
end subroutine MessageBoxW
integer(kind=c_int) function MultiByteToWideChar( &
& codePage, dwFlags, lpMultiByteStr, cchMultiByte, lpWideCharStr, cchWideChar) &
& bind(c, name='MultiByteToWideChar')
import
!gcc$ attributes stdcall :: MultiByteToWideChar
integer(kind=c_int), value :: codePage
integer(kind=c_int), value :: dwFlags
character(kind=c_char), intent(in) :: lpMultiByteStr
integer(kind=c_int), value :: cchMultiByte
type(c_ptr), value :: lpWideCharStr
integer(kind=c_int), value :: cchWideChar
end function MultiByteToWideChar
end interface
end module windows_api
program hello_world_message_box_w
use, intrinsic :: iso_c_binding
use c_string
use windows_api
implicit none
character(len=*, kind=c_char), parameter :: msg = "Hello World" // c_null_char
integer(kind=1), dimension(1:2*len(msg)), target :: hello_world_wchar
integer(kind=c_int) :: bufSize
call memset(c_loc(hello_world_wchar), 0, size(hello_world_wchar))
bufSize = MultiByteToWideChar(0, 1, msg, -1, c_loc(hello_world_wchar), len(msg))
if (bufSize /= 0) call MessageBoxW(c_null_ptr, c_loc(hello_world_wchar), c_loc(hello_world_wchar), 0)
end program hello_world_message_box_w
----
Windows API の MessageBoxA 関数, MessageBoxW 関数を呼び出して出力することもできます．~
Fortran の文字列はデフォルトでは ANSI なので Unicode 版の関数を使用する場合は MultiByteToWideChar 関数を使用して Unicode に変換します．~
gfortran で呼出規約 (calling convention) に stdcall を使用する場合は
!gcc$ attributes stdcall :: MessageBoxA
のように記述します．~
Fortran はデフォルトでは参照渡しなのでポインタの値などを C の関数に値渡しで渡したい場合は仮引数に value 属性を追加する必要があります．~
**標準出力に 1 から 100 までの和を出力 [#m969de65]
----
-sum100.f90
----
program sum_from_1_to_100
implicit none
integer(kind=4) :: i
print '(*(g0))', "Sum from 1 to 100 = ", sum((/(i, i = 1, 100)/))
end program sum_from_1_to_100
----
program sum_from_1_to_100
implicit none
print '(*(g0))', "Sum from 1 to 100 = ", int(100.0_8*(100.0_8+1.0_8)*0.5_8, kind=8)
end program sum_from_1_to_100
----
配列要素の足し算をする場合は sum 関数を使用すると便利です．~
1 から 100 までの和であれば sum 関数を使わずに 100*(100+1)/2 で計算することもできます．~
**コマンドライン引数から整数 N を取得して標準出力に 1 から N までの和を出力 [#cd8aab45]
----
-nsum.f90
----
program sum_from_1_to_n
implicit none
integer(kind=4) :: i, j
integer(kind=4) :: n
character(len=3) :: arg_length_format
character(len=256) :: arg
integer(kind=4) :: ios
if (command_argument_count() == 0) then
call usage()
stop
end if
do i = 1, command_argument_count()
call get_command_argument(i, arg)
if (.not. valid_number(arg)) then
cycle
end if
write(unit=arg_length_format, fmt='(*(g0))') len_trim(arg)
read(unit=arg, fmt='(i' // trim(arg_length_format) // ')', iostat=ios) n
if (ios /= 0) then
cycle
end if
if (n > 0 .and. n < 65536) then
block
integer(kind=4), dimension(:), allocatable :: n_array_4
allocate(n_array_4(1:n))
do concurrent (j = 1:n)
n_array_4(j:j) = j
end do
print '(*(g0))', "Sum from 1 to ", n, " = ", sum(n_array_4)
deallocate(n_array_4)
end block
else if (n >= 65536 .and. n <= huge(n)) then
block
integer(kind=8), dimension(:), allocatable :: n_array_8
allocate(n_array_8(1:n))
do concurrent (j = 1:n)
n_array_8(j:j) = j
end do
print '(*(g0))', "Sum from 1 to ", n, " = ", sum(n_array_8)
deallocate(n_array_8)
end block
else
cycle
end if
end do
contains
subroutine usage()
use, intrinsic :: iso_fortran_env
character(len=256) :: cmd
call get_command(cmd)
write(unit=error_unit, fmt='(*(g0))') "usage: ", trim(cmd), " N ..."
end subroutine usage
function valid_number(arg) result(ok)
character(len=*), intent(in) :: arg
integer(kind=4) :: i
logical(kind=4) :: ok
ok = .false.
do i = 1, len_trim(arg)
if (arg(i:i) < '0' .or. arg(i:i) > '9') then
ok = .false.
exit
else
ok = .true.
end if
end do
end function valid_number
end program sum_from_1_to_n
----
module c_stdlib
use, intrinsic :: iso_c_binding
implicit none
private
public :: atoi
interface
integer(kind=c_int) function atoi(s) bind(c, name='atoi')
import
character(kind=c_char), intent(in) :: s
end function atoi
end interface
end module c_stdlib
program sum_from_1_to_n
use, intrinsic :: iso_c_binding
use c_stdlib
implicit none
integer(kind=4) :: i
integer(kind=4) :: n
character(len=256) :: arg
if (command_argument_count() == 0) then
call usage()
stop
end if
do i = 1, command_argument_count()
call get_command_argument(i, arg)
n = atoi(trim(arg) // c_null_char)
if (n > 0 .and. n <= huge(n)) then
print '(*(g0))', "Sum from 1 to ", n, " = ", &
& int(real(n, kind=8)*(real(n, kind=8)+1.0_8)*0.5_8, kind=8)
else
cycle
end if
end do
contains
subroutine usage()
use, intrinsic :: iso_fortran_env
character(len=256) :: cmd
call get_command(cmd)
write(unit=error_unit, fmt='(*(g0))') "usage: ", trim(cmd), " N ..."
end subroutine usage
end program sum_from_1_to_n
----
文字列から数値への変換は read 文で行います．~
C の atoi 関数で文字列から数値へ変換することもできます．~
数値から文字列への変換は write 文で行います．~
最初のプログラムは 1 から N まで sum 関数で足し算をしています．~
2番めのプログラムは N(N+1)/2 で計算しています．~
数が大きくなると N(N+1)/2 の計算式のほうが早く計算できます．~
ただし Fortran の組み込みの型を使用して大きな数を扱うのは限界があります．~
大きな数で正確な演算結果が必要な場合は[[多倍長整数ライブラリ:http://ja.wikipedia.org/wiki/%E4%BB%BB%E6%84%8F%E7%B2%BE%E5%BA%A6%E6%BC%94%E7%AE%97#.E3.83.A9.E3.82.A4.E3.83.96.E3.83.A9.E3.83.AA]]を使用してプログラムを作成することをおすすめします．~
多倍長整数を扱うライブラリとして例えば [[GMP:http://gmplib.org/]] があります．~
C で簡単に記述できます．~
-[[C#nsum]] を参照．
**cat ライクなコマンド [#s0a9990f]
----
-cat2.f90
----
program cat2
use, intrinsic :: iso_c_binding
use, intrinsic :: iso_fortran_env
implicit none
integer(kind=4) :: i
character(len=256) :: arg
character(len=65536) :: line
integer(kind=4) :: fno
integer(kind=4) :: ios
integer(kind=4) :: length
do i = 0, command_argument_count()
call get_command_argument(i, arg)
if (i /= 0) then
block
logical(kind=4) :: arg_exist
inquire(file=arg, exist=arg_exist)
if (.not. arg_exist .and. arg /= "-") then
write(unit=error_unit, fmt='(*(g0))') trim(arg), ": No such file or directory"
cycle
end if
end block
end if
if (command_argument_count() == 0 .or. arg == "-") then
read(unit=input_unit, fmt='(a)', advance='no', iostat=ios, size=length) line
if (ios < 0) then
write(unit=output_unit, fmt='(*(g0))') line(1:length)
cycle
end if
else
if (i == 0) cycle
open(newunit=fno, file=arg, form='formatted', access='sequential', status='old', action='read')
end if
do
read(unit=fno, fmt='(a)', advance='no', iostat=ios, size=length) line
if (ios < 0) then
write(unit=output_unit, fmt='(*(g0))', advance='no') line(1:length), new_line('a')
cycle
else
exit
end if
end do
if (arg /= "-") then
block
logical(kind=4) :: arg_open
inquire(unit=fno, opened=arg_open)
if (arg_open) then
close(unit=fno)
end if
end block
end if
end do
end program cat2
----
command_argument_count でコマンドライン引数の個数を取得できます．~
get_command_argument でコマンドライン引数を取得できます．~
open 文で newunit を使用すれば自分で unit 番号 (装置番号) を指定しなくても自動的に空いた unit 番号を割り振ってくれます．~
**Python や C などのプログラミング言語から Fortran を呼び出す [#kaea5749]
-[[Calling Fortran from Python:http://www.sfu.ca/~mawerder/notes/calling_fortran_from_python.html]]
-[[Calling Fortran from C:http://www.sfu.ca/~mawerder/notes/calling_fortran_from_c.html]]
-[[f2pyを使ってfortranでpythonのモジュールを書く:http://qiita.com/airtoxin/items/b632f2b3f219610f3990]]
-[[PythonからFortranのサブルーチンを呼ぶ。:http://d.hatena.ne.jp/ignisan/20121017/p1]]
-[[メモリマップドファイルを使ったデータの共有:http://rakasaka.fc2web.com/delphi/mapping.html]]
**Fortran を書かずに Fortran を使う方法 [#y2fbc907]
-[https://github.com/ledyba/FortranWithoutFortran Fortranを書かずにFortranを書いた]
-[http://ledyba.org/2014/06/13235005.php Fortranが書きたくないなら機械語を埋め込めばいいじゃないっ！]
-https://gist.github.com/ledyba
--[https://gist.github.com/ledyba/074d7d23916565b1ab59 Fortranは書きやすいなぁ（棒読み）]
--[https://gist.github.com/ledyba/6e604cadd1b572367a58 闇のFortran]
--[https://gist.github.com/ledyba/cb75d5d16ed2d87e182a Fortranで任意のx86コードを実行する]
*[[fwdsumatrapdf>SumatraPDF/fwdsumatrapdf]] &aname(fwdsumatrapdf); [#uf675bd5]
**Fortran 版 [#k22b610d]
GNU Fortran (gfortran) 4.8.1 で動作確認しています．~
[[MinGW]] の gfortran でビルドできます．~
$ gfortran -Wall -Ofast -march=native -std=f2008 -static -o fwdsumatrapdf.exe fwdsumatrapdf.f90
----
-fwdsumatrapdf.f90
----
! vim: ts=4 sw=4 expandtab:
! $ gfortran -Wall -Ofast -march=native -std=f2008 -static -o fwdsumatrapdf.exe fwdsumatrapdf.f90
module c_string
use, intrinsic :: iso_c_binding
implicit none
private
public :: memset, wcslen, wcscat
interface
subroutine memset(buf, ch, n) bind(c, name='memset')
use, intrinsic :: iso_c_binding
type(c_ptr), value :: buf
integer(kind=c_int), value :: ch
integer(kind=c_size_t), value :: n
end subroutine memset
integer(kind=c_int) function wcslen(s) bind(c, name='wcslen')
use, intrinsic :: iso_c_binding
type(c_ptr), value :: s
end function wcslen
subroutine wcscat(dst, src) bind(c, name='wcscat')
use, intrinsic :: iso_c_binding
type(c_ptr), value :: dst
type(c_ptr), value :: src
end subroutine wcscat
end interface
end module c_string
module windows_api
use, intrinsic :: iso_c_binding
implicit none
private
public :: MultiByteToWideChar, &
& RegOpenKeyExW, &
& RegQueryValueExW, &
& RegCloseKey, &
& CreateProcessW, &
& WaitForInputIdle, &
& DdeInitializeW, &
& DdeUninitialize, &
& DdeCreateStringHandleW, &
& DdeFreeStringHandle, &
& DdeCreateDataHandle, &
& DdeFreeDataHandle, &
& DdeConnect, &
& DdeDisconnect, &
& DdeClientTransaction, &
& DdeGetLastError, &
& STARTUPINFOW, &
& PROCESS_INFORMATION, &
& HKEY_LOCAL_MACHINE, &
& KEY_QUERY_VALUE, &
& DMLERR_NO_ERROR, &
& APPCMD_CLIENTONLY, &
& CP_WINUNICODE, &
& CF_UNICODETEXT, &
& XCLASS_FLAGS, &
& XTYP_EXECUTE, &
& TIMEOUT
integer(kind=c_long), parameter :: HKEY_LOCAL_MACHINE = transfer(z'80000002', mold=c_long)
integer(kind=c_int), parameter :: KEY_QUERY_VALUE = transfer(z'1', mold=c_int)
integer(kind=c_int), parameter :: DMLERR_NO_ERROR = transfer(0, mold=c_int)
integer(kind=c_int), parameter :: APPCMD_CLIENTONLY = transfer(z'10', mold=c_int)
integer(kind=c_int), parameter :: CP_WINUNICODE = transfer(1200, mold=c_int)
integer(kind=c_int), parameter :: CF_UNICODETEXT = transfer(13, mold=c_int)
integer(kind=c_int), parameter :: XCLASS_FLAGS = transfer(z'4000', mold=c_int)
integer(kind=c_int), parameter :: XTYP_EXECUTE = transfer(ior(transfer(z'50', mold=c_int), XCLASS_FLAGS), mold=c_int)
integer(kind=c_int), parameter :: TIMEOUT = transfer(10000, mold=c_int)
type, bind(c) :: STARTUPINFOW
integer(kind=c_int) :: cb
type(c_ptr) :: lpReserved
type(c_ptr) :: lpDesktop
type(c_ptr) :: lpTitle
integer(kind=c_int) :: dwX
integer(kind=c_int) :: dwY
integer(kind=c_int) :: dwXSize
integer(kind=c_int) :: dwYSize
integer(kind=c_int) :: dwXCountChars
integer(kind=c_int) :: dwYCountChars
integer(kind=c_int) :: dwFillAttributes
integer(kind=c_int) :: dwFlags
integer(kind=c_short) :: dwShowWindow
integer(kind=c_short) :: cbReserved2
type(c_ptr) :: lpReserved2
type(c_ptr) :: hStdInput
type(c_ptr) :: hStdOutput
type(c_ptr) :: hStdError
end type STARTUPINFOW
type, bind(c) :: PROCESS_INFORMATION
type(c_ptr) :: hProcess
type(c_ptr) :: hThread
integer(kind=c_int) :: dwProcessId
integer(kind=c_int) :: dwThreadId
end type PROCESS_INFORMATION
interface
subroutine RegOpenKeyExW(hKey, lpSubKey, ulOptions, samDesired, phkResult) bind(c, name='RegOpenKeyExW')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: RegOpenKeyExW
integer(c_long), value :: hKey
type(c_ptr), value :: lpSubKey
integer(kind=c_int), value :: ulOptions
integer(kind=c_int), value :: samDesired
type(c_ptr), value :: phkResult
end subroutine RegOpenKeyExW
subroutine RegQueryValueExW(hKey, lpValueName, lpReserved, lpType, lpData, lpcbData) bind(c, name='RegQueryValueExW')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: RegQueryValueExW
type(c_ptr), value :: hKey
type(c_ptr), value :: lpValueName
type(c_ptr), value :: lpReserved
type(c_ptr), value :: lpType
type(c_ptr), value :: lpData
type(c_ptr), value :: lpcbData
end subroutine RegQueryValueExW
subroutine RegCloseKey(hKey) bind(c, name='RegCloseKey')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: RegCloseKey
type(c_ptr), value :: hKey
end subroutine RegCloseKey
subroutine CreateProcessW( &
& lpApplicationName, lpCommandLine, lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, &
& lpEnvironment, lpCurrentDirectory, lpStartupInfo, lpProcessInformation) bind(c, name='CreateProcessW')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: CreateProcessW
type(c_ptr), value :: lpApplicationName
type(c_ptr), value :: lpCommandLine
type(c_ptr), value :: lpProcessAttributes
type(c_ptr), value :: lpThreadAttributes
integer(kind=c_int), value :: bInheritHandles
integer(kind=c_int), value :: dwCreationFlags
type(c_ptr), value :: lpEnvironment
type(c_ptr), value :: lpCurrentDirectory
type(c_ptr), value :: lpStartupInfo
type(c_ptr), value :: lpProcessInformation
end subroutine CreateProcessW
subroutine WaitForInputIdle(hProcess, dwMilliseconds) bind(c, name='WaitForInputIdle')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: WaitForInputIdle
type(c_ptr), value :: hProcess
integer(kind=c_int), value :: dwMilliseconds
end subroutine WaitForInputIdle
integer(kind=c_int) function MultiByteToWideChar( &
& codePage, dwFlags, lpMultiByteStr, cchMultiByte, lpWideCharStr, cchWideChar) &
& bind(c, name='MultiByteToWideChar')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: MultiByteToWideChar
integer(kind=c_int), value :: codePage
integer(kind=c_int), value :: dwFlags
character(kind=c_char), intent(in) :: lpMultiByteStr
integer(kind=c_int), value :: cchMultiByte
type(c_ptr), value :: lpWideCharStr
integer(kind=c_int), value :: cchWideChar
end function MultiByteToWideChar
subroutine DdeInitializeW(pidInst, pfnCallback, afCmd, ulRes) bind(c, name='DdeInitializeW')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeInitializeW
type(c_ptr), value :: pidInst
type(c_ptr), value :: pfnCallback
integer(kind=c_int), value :: afCmd
integer(kind=c_int), value :: ulRes
end subroutine DdeInitializeW
subroutine DdeUninitialize(idInst) bind(c, name='DdeUninitialize')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeUninitialize
integer(kind=c_int), value :: idInst
end subroutine DdeUninitialize
type(c_ptr) function DdeCreateStringHandleW(idInst, psz, iCodePage) bind(c, name='DdeCreateStringHandleW')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeCreateStringHandleW
integer(kind=c_int), value :: idInst
type(c_ptr), value :: psz
integer(kind=c_int), value :: iCodePage
end function DdeCreateStringHandleW
subroutine DdeFreeStringHandle(idInst, hsz) bind(c, name='DdeFreeStringHandle')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeFreeStringHandle
integer(kind=c_int), value :: idInst
type(c_ptr), value :: hsz
end subroutine DdeFreeStringHandle
type(c_ptr) function DdeCreateDataHandle(idInst, pSrc, cb, cbOff, hszItem, wFmt, afCmd) bind(c, name='DdeCreateDataHandle')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeCreateDataHandle
integer(kind=c_int), value :: idInst
type(c_ptr), value :: pSrc
integer(kind=c_int), value :: cb
integer(kind=c_int), value :: cbOff
type(c_ptr), value :: hszItem
integer(kind=c_int), value :: wFmt
integer(kind=c_int), value :: afCmd
end function DdeCreateDataHandle
subroutine DdeFreeDataHandle(hData) bind(c, name='DdeFreeDataHandle')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeFreeDataHandle
type(c_ptr), value :: hData
end subroutine DdeFreeDataHandle
type(c_ptr) function DdeConnect(idInst, hszServer, hszTopic, pCC) bind(c, name='DdeConnect')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeConnect
integer(kind=c_int), value :: idInst
type(c_ptr), value :: hszServer
type(c_ptr), value :: hszTopic
type(c_ptr), value :: pCC
end function DdeConnect
subroutine DdeDisconnect(hConvList) bind(c, name='DdeDisconnect')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeDisconnect
type(c_ptr), value :: hConvList
end subroutine DdeDisconnect
type(c_ptr) function DdeClientTransaction( &
& pData, cbData, hConv, hszItem, wFmt, wType, dwTimeout, pdwResult) bind(c, name='DdeClientTransaction')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeClientTransaction
type(c_ptr), value :: pData
integer(kind=c_int), value :: cbData
type(c_ptr), value :: hConv
type(c_ptr), value :: hszItem
integer(kind=c_int), value :: wFmt
integer(kind=c_int), value :: wType
integer(kind=c_int), value :: dwTimeout
type(c_ptr), value :: pdwResult
end function DdeClientTransaction
integer(kind=c_int) function DdeGetLastError(idInst) bind(c, name='DdeGetLastError')
use, intrinsic :: iso_c_binding
!gcc$ attributes stdcall :: DdeGetLastError
integer(kind=c_int), value :: idInst
end function DdeGetLastError
end interface
end module windows_api
subroutine runSumatraPDF()
use, intrinsic :: iso_c_binding
use windows_api
use c_string
implicit none
character(len=*, kind=c_char), parameter :: keyPath = &
& 'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\SumatraPDF.exe' // c_null_char
integer(kind=1), dimension(:), allocatable, target :: keyPath_wchar
integer(kind=1), dimension(:), allocatable, target :: sumatraPDFRegistry_wchar
character(len=*, kind=c_char), parameter :: doubleQuote = '"' // c_null_char
integer(kind=1), dimension(:), allocatable, target :: doubleQuote_wchar
character(len=*, kind=c_char), parameter :: reuseInstance = '" -reuse-instance' // c_null_char
integer(kind=1), dimension(:), allocatable, target :: reuseInstance_wchar
integer(kind=1), dimension(:), allocatable, target :: sumatraPDFCommandLine_wchar
integer(kind=c_int) :: bufSize
type(c_ptr), target :: subKey
integer(kind=c_int), target :: dwType = transfer(0, mold=c_int)
integer(kind=c_int), target :: sz = transfer(0, mold=c_int)
type(STARTUPINFOW), target :: si
type(PROCESS_INFORMATION), target :: pi
allocate(keyPath_wchar(1:2*len_trim(keyPath)))
allocate(doubleQuote_wchar(1:2*len_trim(doubleQuote)))
allocate(reuseInstance_wchar(1:2*len_trim(reuseInstance)))
bufSize = MultiByteToWideChar(0, 1, keyPath, -1, c_loc(keyPath_wchar), len(keyPath))
bufSize = MultiByteToWideChar(0, 1, doubleQuote, -1, c_loc(doubleQuote_wchar), len(doubleQuote))
bufSize = MultiByteToWideChar(0, 1, reuseInstance, -1, c_loc(reuseInstance_wchar), len(reuseInstance))
call RegOpenKeyExW(HKEY_LOCAL_MACHINE, c_loc(keyPath_wchar), 0, KEY_QUERY_VALUE, c_loc(subKey))
call RegQueryValueExW(subKey, c_null_ptr, c_null_ptr, c_loc(dwType), c_null_ptr, c_loc(sz))
allocate(sumatraPDFRegistry_wchar(sz))
call RegQueryValueExW(subKey, c_null_ptr, c_null_ptr, c_loc(dwType), c_loc(sumatraPDFRegistry_wchar), c_loc(sz))
call RegCloseKey(subKey)
allocate(sumatraPDFCommandLine_wchar( &
& 2*(wcslen(c_loc(doubleQuote_wchar))+wcslen(c_loc(sumatraPDFRegistry_wchar))+wcslen(c_loc(reuseInstance_wchar)))))
call memset(c_loc(sumatraPDFCommandLine_wchar), 0, size(sumatraPDFCommandLine_wchar))
call memset(c_loc(si), 0, c_sizeof(si))
call memset(c_loc(pi), 0, c_sizeof(pi))
call wcscat(c_loc(sumatraPDFCommandLine_wchar), c_loc(doubleQuote_wchar))
call wcscat(c_loc(sumatraPDFCommandLine_wchar), c_loc(sumatraPDFRegistry_wchar))
call wcscat(c_loc(sumatraPDFCommandLine_wchar), c_loc(reuseInstance_wchar))
call CreateProcessW(c_null_ptr, c_loc(sumatraPDFCommandLine_wchar), c_null_ptr, c_null_ptr, 0, 0, c_null_ptr, c_null_ptr, &
& c_loc(si), c_loc(pi))
call WaitForInputIdle(pi%hProcess, TIMEOUT)
deallocate(sumatraPDFCommandLine_wchar)
deallocate(sumatraPDFRegistry_wchar)
deallocate(reuseInstance_wchar)
deallocate(doubleQuote_wchar)
deallocate(keyPath_wchar)
end subroutine runSumatraPDF
subroutine ddeExecute()
use, intrinsic :: iso_fortran_env
use, intrinsic :: iso_c_binding
use windows_api
use c_string
implicit none
character(len=*, kind=c_char), parameter :: server = "SUMATRA" // c_null_char
character(len=*, kind=c_char), parameter :: topic = "control" // c_null_char
character(len=256, kind=c_char) :: pdf
character(len=256, kind=c_char) :: tex
character(len=256, kind=c_char) :: line
character(len=1024, kind=c_char) :: command
integer(kind=1), dimension(:), allocatable, target :: server_wchar
integer(kind=1), dimension(:), allocatable, target :: topic_wchar
integer(kind=1), dimension(:), allocatable, target :: command_wchar
integer(kind=c_int) :: bufSize
integer(kind=c_int), target :: idInstance = transfer(0, mold=c_int)
type(c_ptr), target :: hszServer
type(c_ptr), target :: hszTopic
type(c_ptr), target :: hConvClient
type(c_ptr), target :: hDdeData
type(c_ptr), target :: hDdeTransactionData
block
integer :: i
character(len=256) :: arg
if (command_argument_count() /= 3) then
write(unit=error_unit, fmt='(*(g0))') "Usage: fwdsumatrapdf pdf tex line"
stop
end if
do i = 1, command_argument_count()
call get_command_argument(i, arg)
select case (i)
case (1)
pdf = arg
case (2)
tex = arg
case (3)
line = arg
case default
error stop "Too many arguments!"
end select
end do
end block
command = '[ForwardSearch("' // trim(pdf) // '","' // trim(tex) // '",' // trim(line) // ',0,0,0)]' // c_null_char
allocate(server_wchar(1:2*len_trim(server)))
allocate(topic_wchar(1:2*len_trim(topic)))
allocate(command_wchar(1:2*len_trim(command)))
call memset(c_loc(server_wchar), 0, size(server_wchar))
call memset(c_loc(topic_wchar), 0, size(topic_wchar))
call memset(c_loc(command_wchar), 0, size(command_wchar))
bufSize = MultiByteToWideChar(0, 1, server, -1, c_loc(server_wchar), len(server))
bufSize = MultiByteToWideChar(0, 1, topic, -1, c_loc(topic_wchar), len(topic))
bufSize = MultiByteToWideChar(0, 1, command, -1, c_loc(command_wchar), len(command))
call runSumatraPDF()
call DdeInitializeW(c_loc(idInstance), c_null_ptr, APPCMD_CLIENTONLY, 0)
if (idInstance == 0) then
error stop "DdeInitializeW error"
end if
hszServer = DdeCreateStringHandleW(idInstance, c_loc(server_wchar), CP_WINUNICODE)
if (DdeGetLastError(idInstance) /= DMLERR_NO_ERROR) then
error stop "DdeCreateStringHandleW error"
end if
hszTopic = DdeCreateStringHandleW(idInstance, c_loc(topic_wchar), CP_WINUNICODE)
if (DdeGetLastError(idInstance) /= DMLERR_NO_ERROR) then
error stop "DdeCreateStringHandleW error"
end if
hConvClient = DdeConnect(idInstance, hszServer, hszTopic, c_null_ptr)
if (DdeGetLastError(idInstance) /= DMLERR_NO_ERROR) then
error stop "DdeConnect error"
end if
hDdeData = DdeCreateDataHandle( &
& idInstance, c_loc(command_wchar), ((wcslen(c_loc(command_wchar)) + 1)*2), 0, c_null_ptr, CF_UNICODETEXT, 0)
if (DdeGetLastError(idInstance) /= DMLERR_NO_ERROR) then
error stop "DdeCreateDataHandle error"
end if
hDdeTransactionData = DdeClientTransaction(hDdeData, -1, hConvClient, c_null_ptr, 0, XTYP_EXECUTE, TIMEOUT, c_null_ptr)
if (DdeGetLastError(idInstance) /= DMLERR_NO_ERROR) then
error stop "DdeClientTransaction error"
end if
call DdeFreeDataHandle(hDdeTransactionData)
call DdeFreeDataHandle(hDdeData)
call DdeFreeStringHandle(idInstance, hszServer)
call DdeFreeStringHandle(idInstance, hszTopic)
call DdeDisconnect(hConvClient)
call DdeUninitialize(idInstance)
deallocate(server_wchar)
deallocate(topic_wchar)
deallocate(command_wchar)
end subroutine ddeExecute
program fwdsumatrapdf
implicit none
call ddeExecute()
end program fwdsumatrapdf
----
