*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 -fno-range-check -o fwdsumatrapdf.exe fwdsumatrapdf.f90 ---- -fwdsumatrapdf.f90 ---- ! vim: ts=4 sw=4 expandtab: ! $ gfortran -Wall -Ofast -march=native -std=f2008 -static -fno-range-check -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 = 2147483650 integer(kind=c_int), parameter :: KEY_QUERY_VALUE = 1 integer(kind=c_int), parameter :: DMLERR_NO_ERROR = 0 integer(kind=c_int), parameter :: APPCMD_CLIENTONLY = 16 integer(kind=c_int), parameter :: CP_WINUNICODE = 1200 integer(kind=c_int), parameter :: CF_UNICODETEXT = 13 integer(kind=c_int), parameter :: XCLASS_FLAGS = 16384 integer(kind=c_int), parameter :: XTYP_EXECUTE = ior(80, XCLASS_FLAGS) integer(kind=c_int), parameter :: TIMEOUT = 10000 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 = 0 integer(kind=c_int), target :: sz = 0 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 = 0 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 ----