Changeset 1320 for palm/trunk/SOURCE/temperton_fft.f90
 Timestamp:
 Mar 20, 2014 8:40:49 AM (10 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

palm/trunk/SOURCE/temperton_fft.f90
r392 r1320 4 4 ! Current revisions: 5 5 !  6 ! 6 ! ONLYattribute added to USEstatements, 7 ! kindparameters added to all INTEGER and REAL declaration statements, 8 ! kinds are defined in new module kinds, 9 ! old module precision_kind is removed, 10 ! revision history before 2012 removed, 11 ! comment fields (!:) to be used for variable explanations added to 12 ! all variable declaration statements 7 13 ! 8 14 ! Former revisions: 9 15 !  10 16 ! $Id$ 11 !12 ! 258 20090313 12:36:03Z heinze13 ! Output of messages replaced by message handling routine.14 !15 ! Feb. 200716 ! RCS Log replace by Id keyword, revision history cleaned up17 !18 ! Revision 1.2 2003/04/16 12:49:25 raasch19 ! Abort in case of illegal factors20 17 ! 21 18 ! Revision 1.1 2003/03/12 16:41:59 raasch … … 28 25 !! 29 26 27 USE kinds 28 30 29 IMPLICIT NONE 31 30 … … 35 34 36 35 37 INTEGER :: nfax(10) !array used by *fft991*.38 REAL , ALLOCATABLE :: trig(:) !array used by *fft991*.36 INTEGER(iwp) :: nfax(10) !: array used by *fft991*. 37 REAL(wp), ALLOCATABLE :: trig(:) !: array used by *fft991*. 39 38 40 39 ! 41 40 ! nfft: maximum length of calls to *fft. 42 41 #if defined( __nec ) 43 INTEGER , PARAMETER :: nfft = 25642 INTEGER(iwp), PARAMETER :: nfft = 256 !: 44 43 #else 45 INTEGER , PARAMETER :: nfft = 3244 INTEGER(iwp), PARAMETER :: nfft = 32 !: 46 45 #endif 47 46 48 INTEGER , PARAMETER :: nout = 6 !standard output stream47 INTEGER(iwp), PARAMETER :: nout = 6 !: standard output stream 49 48 50 49 CONTAINS … … 99 98 ! dimension a(n),work(n),trigs(n),ifax(1) 100 99 100 USE kinds 101 101 102 102 IMPLICIT NONE 103 103 104 104 ! Scalar arguments 105 INTEGER :: inc, isign, jump, lot, n 105 INTEGER(iwp) :: inc !: 106 INTEGER(iwp) :: isign !: 107 INTEGER(iwp) :: jump !: 108 INTEGER(iwp) :: lot !: 109 INTEGER(iwp) :: n !: 106 110 107 111 ! Array arguments 108 REAL :: a(*), trigs(*), work(*) 109 INTEGER :: ifax(*) 112 REAL(wp) :: a(*) !: 113 REAL(wp) :: trigs(*) !: 114 REAL(wp) :: work(*) !: 115 INTEGER(iwp) :: ifax(*) !: 110 116 111 117 ! Local scalars: 112 INTEGER :: i, ia, ibase, ierr, ifac, igo, ii, istart, ix, iz, j, jbase, jj, & 113 & k, la, nb, nblox, nfax, nvex, nx 118 INTEGER(iwp) :: i !: 119 INTEGER(iwp) :: ia !: 120 INTEGER(iwp) :: ibase !: 121 INTEGER(iwp) :: ierr !: 122 INTEGER(iwp) :: ifac !: 123 INTEGER(iwp) :: igo !: 124 INTEGER(iwp) :: ii !: 125 INTEGER(iwp) :: istart !: 126 INTEGER(iwp) :: ix !: 127 INTEGER(iwp) :: iz !: 128 INTEGER(iwp) :: j !: 129 INTEGER(iwp) :: jbase !: 130 INTEGER(iwp) :: jj !: 131 INTEGER(iwp) :: k !: 132 INTEGER(iwp) :: la !: 133 INTEGER(iwp) :: nb !: 134 INTEGER(iwp) :: nblox !: 135 INTEGER(iwp) :: nfax !: 136 INTEGER(iwp) :: nvex !: 137 INTEGER(iwp) :: nx !: 114 138 115 139 ! Intrinsic functions 116 INTRINSIC MOD140 ! INTRINSIC MOD 117 141 118 142 … … 316 340 ! 317 341 318 IMPLICIT NONE 342 USE kinds 343 344 IMPLICIT NONE 319 345 320 346 ! Scalar arguments 321 INTEGER :: ierr, ifac, inc1, inc2, inc3, inc4, la, lot, n 347 INTEGER(iwp) :: ierr !: 348 INTEGER(iwp) :: ifac !: 349 INTEGER(iwp) :: inc1 !: 350 INTEGER(iwp) :: inc2 !: 351 INTEGER(iwp) :: inc3 !: 352 INTEGER(iwp) :: inc4 !: 353 INTEGER(iwp) :: la !: 354 INTEGER(iwp) :: lot !: 355 INTEGER(iwp) :: n !: 322 356 323 357 ! Array arguments 324 358 ! REAL :: a(n),b(n),c(n),d(n),trigs(n) 325 REAL :: a(*), b(*), c(*), d(*), trigs(*) 326 359 REAL(wp) :: a(*) !: 360 REAL(wp) :: b(*) !: 361 REAL(wp) :: c(*) !: 362 REAL(wp) :: d(*) !: 363 REAL(wp) :: trigs(*) !: 364 327 365 ! Local scalars: 328 REAL :: a0, a1, a10, a11, a2, a20, a21, a3, a4, a5, a6, b0, b1, b10, b11, & 329 & b2, b20, b21, b3, b4, b5, b6, c1, c2, c3, c4, c5, qrt5, s1, s2, s3, s4, & 330 & s5, sin36, sin45, sin60, sin72, z, zqrt5, zsin36, zsin45, zsin60, & 331 & zsin72 332 INTEGER :: i, ia, ib, ibad, ibase, ic, id, ie, if, ig, igo, ih, iink, ijk, & 333 & ijump, j, ja, jb, jbase, jc, jd, je, jf, jink, k, kb, kc, kd, ke, kf, & 334 & kstop, l, m 366 REAL(wp) :: a0 !: 367 REAL(wp) :: a1 !: 368 REAL(wp) :: a10 !: 369 REAL(wp) :: a11 !: 370 REAL(wp) :: a2 !: 371 REAL(wp) :: a20 !: 372 REAL(wp) :: a21 !: 373 REAL(wp) :: a3 !: 374 REAL(wp) :: a4 !: 375 REAL(wp) :: a5 !: 376 REAL(wp) :: a6 !: 377 REAL(wp) :: b0 !: 378 REAL(wp) :: b1 !: 379 REAL(wp) :: b10 !: 380 REAL(wp) :: b11 !: 381 REAL(wp) :: b2 !: 382 REAL(wp) :: b20 !: 383 REAL(wp) :: b21 !: 384 REAL(wp) :: b3 !: 385 REAL(wp) :: b4 !: 386 REAL(wp) :: b5 !: 387 REAL(wp) :: b6 !: 388 REAL(wp) :: c1 !: 389 REAL(wp) :: c2 !: 390 REAL(wp) :: c3 !: 391 REAL(wp) :: c4 !: 392 REAL(wp) :: c5 !: 393 REAL(wp) :: qrt5 !: 394 REAL(wp) :: s1 !: 395 REAL(wp) :: s2 !: 396 REAL(wp) :: s3 !: 397 REAL(wp) :: s4 !: 398 REAL(wp) :: s5 !: 399 REAL(wp) :: sin36 !: 400 REAL(wp) :: sin45 !: 401 REAL(wp) :: sin60 !: 402 REAL(wp) :: sin72 !: 403 REAL(wp) :: z !: 404 REAL(wp) :: zqrt5 !: 405 REAL(wp) :: zsin36 !: 406 REAL(wp) :: zsin45 !: 407 REAL(wp) :: zsin60 !: 408 REAL(wp) :: zsin72 !: 409 410 INTEGER(iwp) :: i !: 411 INTEGER(iwp) :: ia !: 412 INTEGER(iwp) :: ib !: 413 INTEGER(iwp) :: ibad !: 414 INTEGER(iwp) :: ibase !: 415 INTEGER(iwp) :: ic !: 416 INTEGER(iwp) :: id !: 417 INTEGER(iwp) :: ie !: 418 INTEGER(iwp) :: if !: 419 INTEGER(iwp) :: ig !: 420 INTEGER(iwp) :: igo !: 421 INTEGER(iwp) :: ih !: 422 INTEGER(iwp) :: iink !: 423 INTEGER(iwp) :: ijk !: 424 INTEGER(iwp) :: ijump !: 425 INTEGER(iwp) :: j !: 426 INTEGER(iwp) :: ja !: 427 INTEGER(iwp) :: jb !: 428 INTEGER(iwp) :: jbase !: 429 INTEGER(iwp) :: jc !: 430 INTEGER(iwp) :: jd !: 431 INTEGER(iwp) :: je !: 432 INTEGER(iwp) :: jf !: 433 INTEGER(iwp) :: jink !: 434 INTEGER(iwp) :: k !: 435 INTEGER(iwp) :: kb !: 436 INTEGER(iwp) :: kc !: 437 INTEGER(iwp) :: kd !: 438 INTEGER(iwp) :: ke !: 439 INTEGER(iwp) :: kf !: 440 INTEGER(iwp) :: kstop !: 441 INTEGER(iwp) :: l !: 442 INTEGER(iwp) :: m !: 335 443 336 444 ! Intrinsic functions 337 INTRINSIC REAL, SQRT445 ! INTRINSIC REAL, SQRT 338 446 339 447 ! Data statements 340 DATA sin36/0.587785252292473 /, sin72/0.951056516295154/, &341 & qrt5/0.559016994374947 /, sin60/0.866025403784437/448 DATA sin36/0.587785252292473_wp/, sin72/0.951056516295154_wp/, & 449 & qrt5/0.559016994374947_wp/, sin60/0.866025403784437_wp/ 342 450 343 451 … … 438 546 GO TO 170 439 547 30 CONTINUE 440 z = 1.0 /REAL(n)548 z = 1.0_wp/REAL(n) 441 549 DO l = 1, la 442 550 i = ibase … … 551 659 GO TO 170 552 660 60 CONTINUE 553 z = 1.0 /REAL(n)661 z = 1.0_wp/REAL(n) 554 662 zsin60 = z*sin60 555 663 DO l = 1, la … … 658 766 IF (jb>jc) GO TO 170 659 767 80 CONTINUE 660 sin45 = SQRT(0.5 )768 sin45 = SQRT(0.5_wp) 661 769 jbase = 0 662 770 DO l = 1, la … … 680 788 GO TO 170 681 789 90 CONTINUE 682 z = 1.0 /REAL(n)790 z = 1.0_wp/REAL(n) 683 791 DO l = 1, la 684 792 i = ibase … … 843 951 GO TO 170 844 952 120 CONTINUE 845 z = 1.0 /REAL(n)953 z = 1.0_wp/REAL(n) 846 954 zqrt5 = z*qrt5 847 955 zsin36 = z*sin36 … … 1019 1127 GO TO 170 1020 1128 150 CONTINUE 1021 z = 1.0 /REAL(n)1129 z = 1.0_wp/REAL(n) 1022 1130 zsin60 = z*sin60 1023 1131 DO l = 1, la … … 1062 1170 jd = jc + 2*m*inc2 1063 1171 je = jd + 2*m*inc2 1064 z = 1.0 /REAL(n)1172 z = 1.0_wp/REAL(n) 1065 1173 zsin45 = z*SQRT(0.5) 1066 1174 … … 1105 1213 ! Dimension a(n),b(n),c(n),d(n),trigs(n) 1106 1214 1215 USE kinds 1216 1107 1217 IMPLICIT NONE 1108 1218 1109 1219 ! Scalar arguments 1110 INTEGER :: ierr, ifac, inc1, inc2, inc3, inc4, la, lot, n 1220 INTEGER(iwp) :: ierr !: 1221 INTEGER(iwp) :: ifac !: 1222 INTEGER(iwp) :: inc1 !: 1223 INTEGER(iwp) :: inc2 !: 1224 INTEGER(iwp) :: inc3 !: 1225 INTEGER(iwp) :: inc4 !: 1226 INTEGER(iwp) :: la !: 1227 INTEGER(iwp) :: lot !: 1228 INTEGER(iwp) :: n !: 1111 1229 1112 1230 ! Array arguments 1113 REAL :: a(*), b(*), c(*), d(*), trigs(*) 1231 REAL(wp) :: a(*) !: 1232 REAL(wp) :: b(*) !: 1233 REAL(wp) :: c(*) !: 1234 REAL(wp) :: d(*) !: 1235 REAL(wp) :: trigs(*) !: 1114 1236 1115 1237 ! Local scalars: 1116 REAL :: c1, c2, c3, c4, c5, qqrt5, qrt5, s1, s2, s3, s4, s5, sin36, sin45, & 1117 & sin60, sin72, ssin36, ssin45, ssin60, ssin72 1118 INTEGER :: i, ia, ib, ibad, ibase, ic, id, ie, if, igo, iink, ijk, j, ja, & 1119 & jb, jbase, jc, jd, je, jf, jg, jh, jink, jump, k, kb, kc, kd, ke, kf, & 1120 & kstop, l, m 1238 REAL(wp) :: c1 !: 1239 REAL(wp) :: c2 !: 1240 REAL(wp) :: c3 !: 1241 REAL(wp) :: c4 !: 1242 REAL(wp) :: c5 !: 1243 REAL(wp) :: qqrt5 !: 1244 REAL(wp) :: qrt5 !: 1245 REAL(wp) :: s1 !: 1246 REAL(wp) :: s2 !: 1247 REAL(wp) :: s3 !: 1248 REAL(wp) :: s4 !: 1249 REAL(wp) :: s5 !: 1250 REAL(wp) :: sin36 !: 1251 REAL(wp) :: sin45 !: 1252 REAL(wp) :: sin60 !: 1253 REAL(wp) :: sin72 !: 1254 REAL(wp) :: ssin36 !: 1255 REAL(wp) :: ssin45 !: 1256 REAL(wp) :: ssin60 !: 1257 REAL(wp) :: ssin72 !: 1258 1259 INTEGER(iwp) :: i !: 1260 INTEGER(iwp) :: ia !: 1261 INTEGER(iwp) :: ib !: 1262 INTEGER(iwp) :: ibad !: 1263 INTEGER(iwp) :: ibase !: 1264 INTEGER(iwp) :: ic !: 1265 INTEGER(iwp) :: id !: 1266 INTEGER(iwp) :: ie !: 1267 INTEGER(iwp) :: if !: 1268 INTEGER(iwp) :: igo !: 1269 INTEGER(iwp) :: iink !: 1270 INTEGER(iwp) :: ijk !: 1271 INTEGER(iwp) :: j !: 1272 INTEGER(iwp) :: ja !: 1273 INTEGER(iwp) :: jb !: 1274 INTEGER(iwp) :: jbase !: 1275 INTEGER(iwp) :: jc !: 1276 INTEGER(iwp) :: jd !: 1277 INTEGER(iwp) :: je !: 1278 INTEGER(iwp) :: jf !: 1279 INTEGER(iwp) :: jg !: 1280 INTEGER(iwp) :: jh !: 1281 INTEGER(iwp) :: jink !: 1282 INTEGER(iwp) :: jump !: 1283 INTEGER(iwp) :: k !: 1284 INTEGER(iwp) :: kb !: 1285 INTEGER(iwp) :: kc !: 1286 INTEGER(iwp) :: kd !: 1287 INTEGER(iwp) :: ke !: 1288 INTEGER(iwp) :: kf !: 1289 INTEGER(iwp) :: kstop !: 1290 INTEGER(iwp) :: l !: 1291 INTEGER(iwp) :: m !: 1121 1292 1122 1293 ! Local arrays: 1123 REAL :: a10(nfft), a11(nfft), a20(nfft), a21(nfft), b10(nfft), b11(nfft), b20(nfft), & 1124 & b21(nfft) 1294 REAL(wp) :: a10(nfft) !: 1295 REAL(wp) :: a11(nfft) !: 1296 REAL(wp) :: a20(nfft) !: 1297 REAL(wp) :: a21(nfft) !: 1298 REAL(wp) :: b10(nfft) !: 1299 REAL(wp) :: b11(nfft) !: 1300 REAL(wp) :: b20(nfft) !: 1301 REAL(wp) :: b21(nfft) !: 1125 1302 1126 1303 ! Intrinsic functions 1127 INTRINSIC SQRT1304 ! INTRINSIC SQRT 1128 1305 1129 1306 ! Data statements 1130 DATA sin36/0.587785252292473 /, sin72/0.951056516295154/, &1131 & qrt5/0.559016994374947 /, sin60/0.866025403784437/1307 DATA sin36/0.587785252292473_wp/, sin72/0.951056516295154_wp/, & 1308 & qrt5/0.559016994374947_wp/, sin60/0.866025403784437_wp/ 1132 1309 1133 1310 … … 1622 1799 GO TO 170 1623 1800 120 CONTINUE 1624 qqrt5 = 2.0 *qrt51625 ssin36 = 2.0 *sin361626 ssin72 = 2.0 *sin721801 qqrt5 = 2.0_wp*qrt5 1802 ssin36 = 2.0_wp*sin36 1803 ssin72 = 2.0_wp*sin72 1627 1804 DO l = 1, la 1628 1805 i = ibase … … 1838 2015 jg = jf + jink 1839 2016 jh = jg + jink 1840 ssin45 = SQRT(2.0 )2017 ssin45 = SQRT(2.0_wp) 1841 2018 1842 2019 DO l = 1, la … … 1889 2066 1890 2067 1891 USE control_parameters 1892 USE pegrid 2068 USE control_parameters, & 2069 ONLY: message_string 2070 2071 USE kinds 1893 2072 1894 2073 IMPLICIT NONE 1895 2074 1896 2075 ! Scalar arguments 1897 INTEGER :: n2076 INTEGER(iwp) :: n !: 1898 2077 1899 2078 ! Array arguments 1900 REAL :: trigs(*) 1901 INTEGER :: ifax(*) 2079 INTEGER(iwp) :: ifax(*) !: 2080 REAL(wp) :: trigs(*) !: 2081 1902 2082 1903 2083 ! Local scalars: 1904 REAL :: angle, del 1905 INTEGER :: i, ifac, ixxx, k, l, nfax, nhl, nil, nu 2084 REAL(wp) :: angle !: 2085 REAL(wp) :: del !: 2086 INTEGER(iwp) :: i !: 2087 INTEGER(iwp) :: ifac !: 2088 INTEGER(iwp) :: ixxx !: 2089 INTEGER(iwp) :: k !: 2090 INTEGER(iwp) :: l !: 2091 INTEGER(iwp) :: nfax !: 2092 INTEGER(iwp) :: nhl !: 2093 INTEGER(iwp) :: nil !: 2094 INTEGER(iwp) :: nu !: 1906 2095 1907 2096 ! Local arrays: 1908 INTEGER :: jfax(10), lfax(7) 2097 INTEGER(iwp) :: jfax(10) !: 2098 INTEGER(iwp) :: lfax(7) !: 1909 2099 1910 2100 ! Intrinsic functions 1911 INTRINSIC ASIN, COS, MOD, REAL, SIN2101 ! INTRINSIC ASIN, COS, MOD, REAL, SIN 1912 2102 1913 2103 ! Data statements … … 1918 2108 ixxx = 1 1919 2109 1920 del = 4.0 *ASIN(1.0)/REAL(n)2110 del = 4.0_wp*ASIN(1.0_wp)/REAL(n) 1921 2111 nil = 0 1922 2112 nhl = (n/2)  1
Note: See TracChangeset
for help on using the changeset viewer.