From f58598bc6561fd8b7ee6bbd2ac54fb7e55d11d8c Mon Sep 17 00:00:00 2001 From: Thomas A Caswell Date: Fri, 14 Feb 2025 12:04:52 -0500 Subject: [PATCH 1/3] MNT: switch from TYPE*N -> TYPE(kind=N) --- sources/DIFFaXsubs/DIFFaX.inc | 27 +- sources/DIFFaXsubs/DIFFaX.par | 24 +- sources/DIFFaXsubs/DIFFaXsubs.for | 442 +++++++++++++++--------------- sources/convcell.f | 132 ++++----- sources/histogram2d.for | 18 +- sources/histosigma2d.for | 22 +- sources/pack_f.for | 45 ++- sources/polymask.for | 10 +- sources/powsubs/acosd.for | 4 +- sources/powsubs/cosd.for | 4 +- sources/powsubs/epsvoigt.for | 36 +-- sources/powsubs/expint.for | 22 +- sources/powsubs/gauleg.for | 4 +- sources/powsubs/gerfc.for | 6 +- sources/powsubs/hfunc.for | 10 +- sources/powsubs/lorentz.for | 10 +- sources/powsubs/psvfcjexpo.for | 140 +++++----- sources/powsubs/psvfcjo.for | 134 ++++----- sources/powsubs/psvoigt.for | 46 ++-- sources/powsubs/sind.for | 4 +- sources/powsubs/tand.for | 4 +- sources/pydiffax.for | 36 +-- sources/pypowder.for | 70 ++--- sources/pyspg.for | 16 +- sources/pytexture.for | 10 +- sources/spotmask.for | 10 +- sources/spsubs/genhkl.for | 22 +- sources/spsubs/sglatc.for | 18 +- sources/spsubs/sglcen.for | 10 +- sources/spsubs/sgmtml.for | 8 +- sources/spsubs/sgoprn.for | 6 +- sources/spsubs/sgrmat.for | 8 +- sources/spsubs/sgroupnp.for | 12 +- sources/spsubs/sgtrcf.for | 14 +- sources/texturesubs/aplms.for | 6 +- sources/texturesubs/cosd.for | 4 +- sources/texturesubs/dgammln.for | 6 +- sources/texturesubs/factln.for | 10 +- sources/texturesubs/plmpsi.for | 10 +- sources/texturesubs/qlmn.for | 12 +- sources/texturesubs/qlmninit.for | 8 +- sources/texturesubs/sind.for | 4 +- sources/unpack_cbf.for | 26 +- 43 files changed, 736 insertions(+), 734 deletions(-) diff --git a/sources/DIFFaXsubs/DIFFaX.inc b/sources/DIFFaXsubs/DIFFaX.inc index a98bab5f9..fd512c41e 100644 --- a/sources/DIFFaXsubs/DIFFaX.inc +++ b/sources/DIFFaXsubs/DIFFaX.inc @@ -100,7 +100,7 @@ * ignored for the purposes of applying * * instrumental broadening. * ************************************************************************ -********************** integer*4 variables ********************* +******************* integer(kind=4) variables ****************** ************************************************************************ *d-> a_number(MAX_A,MAX_L) * * - numeric label of atom in the layer. * @@ -197,7 +197,7 @@ * 'data.sfc') * * * ************************************************************************ -*********************** real*8 variables *********************** +******************** real(kind=8) variables ******************** ************************************************************************ * a0 - One of seven reciprocal lattice constants * *d-> a_B(MAX_A,MAX_L) * @@ -353,7 +353,7 @@ * a-direction. Wx and Wy in Angstroms. * * * ************************************************************************ -********************* complex*16 variables ********************* +****************** complex(kind=8) variables ******************* ************************************************************************ * l_phi(MAX_L,MAX_L) * * - Phases of components of 'mat' * @@ -384,33 +384,34 @@ | k_mirror, hk_mirror, check_sym, same_rz, any_sharp, | same_layer, finite_width,debug * - integer*4 l_seq(XP_MAX), pow(MAX_BIN), a_type(MAX_A,MAX_L), + integer(kind=4) l_seq(XP_MAX), pow(MAX_BIN), a_type(MAX_A,MAX_L), | l_n_atoms(MAX_L), l_symmetry(MAX_L), l_actual(MAX_L), | a_number(MAX_A,MAX_L), e_sf(MAX_TA) - integer*4 SymGrpNo, no_trials, h_bnd, k_bnd, cntrl, max_pow, + integer(kind=4) SymGrpNo, no_trials, h_bnd, k_bnd, cntrl, max_pow, | l_cnt,full_brd, full_shrp, sadblock, loglin, bitdepth, | rad_type, n_layers, n_actual, blurring, n_atoms, maxsad - integer*4 NONE, CENTRO, GAUSS, LORENZ, PS_VGT, PV_GSS, PV_LRN, - | X_RAY, NEUTRN, ELECTN + integer(kind=4) NONE, CENTRO, GAUSS, LORENZ, PS_VGT, PV_GSS, + | PV_LRN, X_RAY, NEUTRN, ELECTN * - real*8 l_alpha(MAX_L,MAX_L), l_r(3,MAX_L,MAX_L), l_g(MAX_L), + real(kind=8) l_alpha(MAX_L,MAX_L), l_r(3,MAX_L,MAX_L), l_g(MAX_L), | a_pos(3,MAX_A,MAX_L), a_B(MAX_A,MAX_L), | a_occup(MAX_A,MAX_L), high_atom(MAX_L), low_atom(MAX_L), | r_B11(MAX_L,MAX_L),r_B22(MAX_L,MAX_L),r_B33(MAX_L,MAX_L), | r_B12(MAX_L,MAX_L),r_B23(MAX_L,MAX_L),r_B31(MAX_L,MAX_L), | hx_ky(MAX_A,MAX_L), spec(MAX_SP), brd_spc(MAX_SP), | detune(MAX_L,MAX_L), x_sf(9,MAX_TA) - real*8 a_B11,a_B22,a_B33,a_B12,a_B23,a_B31 - real*8 tolerance, max_var, max_angle, l_bnd, l_rz, + real(kind=8) a_B11,a_B22,a_B33,a_B12,a_B23,a_B31 + real(kind=8) tolerance, max_var, max_angle, l_bnd, l_rz, | PI, PI2, RAD2DEG, DEG2RAD, scaleint, brightness, lambda, | th2_min, th2_max, d_theta, h_start, k_start,h_end, k_end, | cell_a, cell_b, cell_c, cell_gamma, pv_u, pv_v, pv_w, | pv_gamma, FWHM, mltplcty, bnds_wt, theta1, theta2, a0, b0, | c0, d0, ab0, bc0, ca0, tiny_inty, fatsWalla_hk - real*8 formfactor(FFACT_SIZE),ffact_scale,Wa,Wb,ffhkcnst,ffwdth - real*8 n_sf(MAX_TA) + real(kind=8) formfactor(FFACT_SIZE),ffact_scale,Wa,Wb,ffhkcnst, + | ffwdth + real(kind=8) n_sf(MAX_TA) * - complex*16 mat(MAX_L,MAX_L), mat1(MAX_L,MAX_L), + complex(kind=8) mat(MAX_L,MAX_L), mat1(MAX_L,MAX_L), | l_phi(MAX_L,MAX_L), wavefn * common /chars1/ a_name, atom_l diff --git a/sources/DIFFaXsubs/DIFFaX.par b/sources/DIFFaXsubs/DIFFaX.par index 51d51030f..76f9222c8 100644 --- a/sources/DIFFaXsubs/DIFFaX.par +++ b/sources/DIFFaXsubs/DIFFaX.par @@ -56,26 +56,26 @@ ************************************************************************ * implicit none - integer*4 MAX_L, MAX_A, MAX_TA, MAX_SP, SADSIZE + integer(kind=4) MAX_L, MAX_A, MAX_TA, MAX_SP, SADSIZE parameter (MAX_L=20,MAX_A=200,MAX_TA=20,MAX_SP=20001,SADSIZE=256) - integer*4 XP_MAX, RCSV_MAX, MAX_NAM, MAX_BIN + integer(kind=4) XP_MAX, RCSV_MAX, MAX_NAM, MAX_BIN parameter (XP_MAX=5000, RCSV_MAX=1022, MAX_NAM=31, MAX_BIN=10) - integer*4 FFACT_SIZE, N_SIGMAS + integer(kind=4) FFACT_SIZE, N_SIGMAS parameter (FFACT_SIZE=201, N_SIGMAS=7) - real*8 inf_width + real(kind=8) inf_width parameter (inf_width=1.0D4) - integer*4 ip, op, df, sf, dp, sy, sp, sk, sa + integer(kind=4) ip, op, df, sf, dp, sy, sp, sk, sa parameter (ip=5,op=6,df=2,sf=4,dp=10,sy=11,sp=12,sk=13,sa=14) - integer*4 scrtch + integer(kind=4) scrtch parameter (scrtch = 3) - integer*4 CLIP + integer(kind=4) CLIP parameter (CLIP = 14) - integer*4 UNKNOWN + integer(kind=4) UNKNOWN parameter (UNKNOWN = -1) * define some useful numerical constants - complex*16 C_ZERO, C_ONE + complex(kind=8) C_ZERO, C_ONE parameter (C_ZERO = (0.0D0,0.0D0), C_ONE = (1.0D0,0.0D0)) - real*8 ZERO, QUARTER, HALF, ONE, TWO, THREE, FOUR, FIVE, + real(kind=8) ZERO, QUARTER, HALF, ONE, TWO, THREE, FOUR, FIVE, | SIX, EIGHT, TEN, TWELVE, TWENTY, FIFTY, HUNDRED, | ONE_EIGHTY parameter (ZERO = 0.0D0, QUARTER = 0.25D0, HALF = 0.5D0, @@ -83,13 +83,13 @@ | FIVE = 5.0D0, SIX = 6.0D0, EIGHT = 8.0D0, TEN = 10.0D0, | TWELVE = 12.0D0, TWENTY = 20.0D0, FIFTY = 50.0D0, | HUNDRED = 100.0D0, ONE_EIGHTY = 180.0D0) - real*8 eps1, eps2, eps3, eps4, eps5, eps6, eps7, eps8, eps9, + real(kind=8) eps1, eps2, eps3, eps4, eps5, eps6, eps7, eps8, eps9, | eps10, eps14 parameter (eps1 = 1.0D-1, eps2 = 1.0D-2, eps3 = 1.0D-3, | eps4 = 1.0D-4, eps5 = 1.0D-5, eps6 = 1.0D-6, | eps7 = 1.0D-7, eps8 = 1.0D-8, eps9 = 1.0D-9, | eps10 = 1.0D-10, eps14 = 1.0D-14) - real*8 EIGHTBITS, FIFTEENBITS, SIXTEENBITS + real(kind=8) EIGHTBITS, FIFTEENBITS, SIXTEENBITS parameter (EIGHTBITS = 256.0D0, FIFTEENBITS = 32768.0D0, | SIXTEENBITS = 65536.0D0) * diff --git a/sources/DIFFaXsubs/DIFFaXsubs.for b/sources/DIFFaXsubs/DIFFaXsubs.for index 45ab1abad..931602b27 100644 --- a/sources/DIFFaXsubs/DIFFaXsubs.for +++ b/sources/DIFFaXsubs/DIFFaXsubs.for @@ -28,8 +28,8 @@ block data implicit none * - integer*4 NONE, CENTRO, GAUSS, LORENZ, PS_VGT, PV_GSS, PV_LRN, - | X_RAY, NEUTRN, ELECTN + integer(kind=4) NONE, CENTRO, GAUSS, LORENZ, PS_VGT, PV_GSS, + | PV_LRN, X_RAY, NEUTRN, ELECTN * * The common block 'consts' also occurs in the file 'DIFFaX.inc' common /consts/ NONE, CENTRO, GAUSS, LORENZ, PS_VGT, PV_GSS, @@ -62,17 +62,17 @@ * AGLQ16 returns the adaptively integrated value. * ______________________________________________________________________ * - real*8 function AGLQ16(h, k, a, b, ok) + real(kind=8) function AGLQ16(h, k, a, b, ok) include 'DIFFaX.par' * save * - integer*4 h, k - real*8 a, b + integer(kind=4) h, k + real(kind=8) a, b logical ok * - integer*4 maxstk, stp, n, n2 + integer(kind=4) maxstk, stp, n, n2 parameter(maxstk = 200) - real*8 sum, sum1, sum2, sum3, epsilon, epsilon2, GLQ16, + real(kind=8) sum, sum1, sum2, sum3, epsilon, epsilon2, GLQ16, | stk(maxstk), d1, d2, d3, x parameter(epsilon = FIVE * eps4) * @@ -173,17 +173,17 @@ include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 n, list(n) - real*8 ll(n), ag_l(16) - integer*4 h, k - complex*16 f(MAX_L,16) + integer(kind=4) n, list(n) + real(kind=8) ll(n), ag_l(16) + integer(kind=4) h, k + complex(kind=8) f(MAX_L,16) logical ok * logical know_f - integer*4 i, j, m, p, max_poly + integer(kind=4) i, j, m, p, max_poly parameter (max_poly = 10) - real*8 Q2, l - complex*16 ff(MAX_L,max_poly), fa(MAX_L), f_ans, f_error + real(kind=8) Q2, l + complex(kind=8) ff(MAX_L,max_poly), fa(MAX_L), f_ans, f_error * * external subroutines (Some compilers need them declared external) * external POLINT, GET_F @@ -259,9 +259,9 @@ include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 n + integer(kind=4) n * - integer*4 i, j, itmp + integer(kind=4) i, j, itmp * BINPOW = .false. * @@ -309,12 +309,12 @@ * BOUNDS returns the translated value of x. x is not modified. * ______________________________________________________________________ * - real*8 function BOUNDS(x) + real(kind=8) function BOUNDS(x) include 'DIFFaX.par' * - real*8 x + real(kind=8) x * - real*8 y + real(kind=8) y * y = x - int(x) + ONE y = y - int(y) @@ -361,8 +361,8 @@ logical diad, triad, tetrad logical TST_ROT, TST_MIR logical cell90, cell120, eq_sides - integer*4 GET_SYM, LENGTH, idum - real*8 tmp + integer(kind=4) GET_SYM, LENGTH, idum + real(kind=8) tmp * * external functions external TST_ROT, TST_MIR, GET_SYM, LENGTH @@ -626,7 +626,7 @@ * on the ratio Wa/Wb. The costly logarithm function is avoided by * using its derivative. * When off the 00l axis, the broadening is modelled as a symmetric -* Lorentzian whose half-width depends on the angle that the Ewald +* Lorentzian whose half-width depends on the angle that the Ewald * sphere intercepts the disk of confusion (controlled by l). If * the lateral dimensions are not equal, then the half width is also * dependent on h and k. The Lorentzian is pre-computed in OPTIMZ to gain @@ -658,13 +658,14 @@ include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 h, k, m, max_indx + integer(kind=4) h, k, m, max_indx * - real*8 l0, l1, x + real(kind=8) l0, l1, x * - integer*4 n, p, i, indx + integer(kind=4) n, p, i, indx * - real*8 S, h_wdth, n_hw, d_hk, norm, l, scale, avg, xx, dx, tmp + real(kind=8) S, h_wdth, n_hw, d_hk, norm, l, scale, avg, xx, dx, + | tmp * * indx indexes into the arrays spec and brd_spec * n indexes into the array formfactor @@ -699,7 +700,7 @@ dx = ((ONE-xx)*sqrt(dble(indx))*tmp + xx)*tmp if(m+indx-1.le.max_indx) brd_spc(m+indx-1) = dx norm = norm + dx -* eps5 is reasonable. However, it may be worth experimenting more. +* eps5 is reasonable. However, it may be worth experimenting more. if(dx.lt.eps5) goto 20 goto 10 20 continue @@ -757,14 +758,14 @@ ************************************************************************ ****************************LINPACK ROUTINES**************************** ************************************************************************ -* +* * The following are the standard Linpack routines for solving complex * simultaneous equations. They were found to reduce DIFFaX run time by -* significant amount (30% in one case) compared with the Numerical +* significant amount (30% in one case) compared with the Numerical * Recipes routines LUDCMP and LUBKSB. The only changes are -* -* complex -> complex*16 -* real -> real*8 +* +* complex -> complex(kind=8) +* real -> real(kind=8) * real() -> dble() * aimag -> dimag * @@ -832,9 +833,9 @@ implicit none * integer lda,n,ipvt(1),job - complex*16 a(lda,1),b(1) + complex(kind=8) a(lda,1),b(1) * - complex*16 CDOTC,t + complex(kind=8) CDOTC,t integer k,kb,l,nm1 * MMJT: external subroutine external CAXPY @@ -905,7 +906,7 @@ subroutine CAXPY(n,ca,cx,incx,cy,incy) implicit none * - complex*16 cx(1),cy(1),ca + complex(kind=8) cx(1),cy(1),ca integer n,incx,incy * integer i,ix,iy @@ -944,13 +945,13 @@ * vector. * ______________________________________________________________________ * - complex*16 function CDOTC(n,cx,incx,cy,incy) + complex(kind=8) function CDOTC(n,cx,incx,cy,incy) implicit none * - complex*16 cx(1),cy(1) + complex(kind=8) cx(1),cy(1) integer incx,incy,n * - complex*16 ctemp + complex(kind=8) ctemp integer i,ix,iy * ctemp = (0.0,0.0) @@ -1033,13 +1034,13 @@ implicit none * integer lda,n,ipvt(1),info - complex*16 a(lda,1) + complex(kind=8) a(lda,1) * - complex*16 t + complex(kind=8) t integer ICAMAX,j,k,kp1,l,nm1 * - complex*16 zdum - real*8 cabs1 + complex(kind=8) zdum + real(kind=8) cabs1 * * MMJT: external subroutine external CSCAL, CAXPY @@ -1109,7 +1110,7 @@ subroutine CSCAL(n,ca,cx,incx) implicit none * - complex*16 ca,cx(1) + complex(kind=8) ca,cx(1) integer incx,n * integer i,nincx @@ -1143,15 +1144,15 @@ integer function ICAMAX(n,cx,incx) implicit none * - complex*16 cx(1) + complex(kind=8) cx(1) integer incx,n * - real*8 smax + real(kind=8) smax integer i,ix - complex*16 zdum + complex(kind=8) zdum * * statement function - real*8 cabs1 + real(kind=8) cabs1 cabs1(zdum) = abs(dble(zdum)) + abs(dimag(zdum)) * ICAMAX = 0 @@ -1206,8 +1207,8 @@ include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 i, j - real*8 delta + integer(kind=4) i, j + real(kind=8) delta * delta = eps3 * @@ -1255,11 +1256,11 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 r_B(MAX_L,MAX_L) - real*8 av_B + real(kind=8) r_B(MAX_L,MAX_L) + real(kind=8) av_B * - integer*4 i, j, m - real*8 error + integer(kind=4) i, j, m + real(kind=8) error * av_B = ZERO m = 0 @@ -1315,8 +1316,8 @@ C 401 format(1x, g12.5) * logical okay character*80 messge - integer*4 i, j, idum - real*8 RAN3, x, sum + integer(kind=4) i, j, idum + real(kind=8) RAN3, x, sum * external function external RAN3 * @@ -1410,14 +1411,15 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 FN, l_upper - integer*4 view, hk_lim + real(kind=8) FN, l_upper + integer(kind=4) view, hk_lim character*(*) infile logical ok * - integer*4 h, k, i, j, n, info_step, info, cnt, LENGTH, origin - real*8 x, S, S_value, ANGLE, W4, PNTINT, theta, Q2, l - real*8 l_lower, dl, high1, high2, intervals + integer(kind=4) h, k, i, j, n, info_step, info, cnt, LENGTH, + | origin + real(kind=8) x, S, S_value, ANGLE, W4, PNTINT, theta, Q2, l + real(kind=8) l_lower, dl, high1, high2, intervals parameter (intervals = TWENTY) * * external functions (FN is either GLQ16 or AGLQ16) @@ -1683,18 +1685,18 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 FN + real(kind=8) FN character*(*) infile * logical ok, SHARP, on_bndry, l_axis, shrp - integer*4 h, k, h_lower, h_upper, k_lower, k_upper - integer*4 m, i, max_indx - integer*4 LENGTH - real*8 S, Q, theta, tmp, tmp2, tmp3, fact, h_val, k_val - real*8 HKANGL, LL, ANGLE, AGLQ16 - real*8 l, hk_th, x, GLQ16, l_max, min_th, max_th - real*8 W1, l1, l0, d_l, INTENS, L_STEP, W2, W3, l00 - complex*16 f(MAX_L) + integer(kind=4) h, k, h_lower, h_upper, k_lower, k_upper + integer(kind=4) m, i, max_indx + integer(kind=4) LENGTH + real(kind=8) S, Q, theta, tmp, tmp2, tmp3, fact, h_val, k_val + real(kind=8) HKANGL, LL, ANGLE, AGLQ16 + real(kind=8) l, hk_th, x, GLQ16, l_max, min_th, max_th + real(kind=8) W1, l1, l0, d_l, INTENS, L_STEP, W2, W3, l00 + complex(kind=8) f(MAX_L) * * external functions external FN, GLQ16, AGLQ16, INTENS, SHARP, L_STEP, LENGTH @@ -2153,13 +2155,13 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 S2, l - complex*16 f(MAX_L) + real(kind=8) S2, l + complex(kind=8) f(MAX_L) * - integer*4 i, j, m, n, type - real*8 fact(MAX_TA), tmp(MAX_TA), tmp_sum, dot, e_factor, Q2 + integer(kind=4) i, j, m, n, type + real(kind=8) fact(MAX_TA), tmp(MAX_TA), tmp_sum, dot, e_factor, Q2 parameter(e_factor = 0.023934D0) - complex*16 ctmp(MAX_TA), f_uniq(MAX_L), ctmp_sum + complex(kind=8) ctmp(MAX_TA), f_uniq(MAX_L), ctmp_sum * Q2 = QUARTER * S2 * Q2 = sin(theta)**2 / lamba**2 @@ -2293,8 +2295,8 @@ C 401 format(1x, g12.5) include 'DIFFaX.inc' * logical singular, LUDCMP - integer*4 i, j, cnt, index(MAX_L) - real*8 sum, g_mat(MAX_L,MAX_L), Det + integer(kind=4) i, j, cnt, index(MAX_L) + real(kind=8) sum, g_mat(MAX_L,MAX_L), Det * * external function external LUDCMP @@ -2397,11 +2399,11 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 h, k - real*8 l + integer(kind=4) h, k + real(kind=8) l * - real*8 dot, twopi_l, fatsWaller - integer*4 i, j + real(kind=8) dot, twopi_l, fatsWaller + integer(kind=4) i, j * * set up matrix that represents the sequences * Note: mat is in 'i,j' order. @@ -2489,14 +2491,14 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 h, k - real*8 l - complex*16 f(MAX_L), s(MAX_L) + integer(kind=4) h, k + real(kind=8) l + complex(kind=8) f(MAX_L), s(MAX_L) * * i_ok is used by Linpack routines integer i_ok, index(MAX_L) - integer*4 i - complex*16 Det, s_tmp(2) + integer(kind=4) i + complex(kind=8) Det, s_tmp(2) * external subroutines (Some compilers need them declared external) * CGEFA and CGESL are Linpack routines external CGEFA, CGESL @@ -2572,13 +2574,13 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 h, k - real*8 l - complex*16 f(MAX_L), s(MAX_L) + integer(kind=4) h, k + real(kind=8) l + complex(kind=8) f(MAX_L), s(MAX_L) * logical ok, GET_S, MAT2N - integer*4 i, j - complex*16 ctmp, mat_n(MAX_L,MAX_L), tmp_mat(MAX_L,MAX_L) + integer(kind=4) i, j + complex(kind=8) ctmp, mat_n(MAX_L,MAX_L), tmp_mat(MAX_L,MAX_L) * external functions external GET_S, MAT2N * @@ -2678,7 +2680,7 @@ C 401 format(1x, g12.5) * GET_SYM returns one of the ten symmetry flags listed above. * ______________________________________________________________________ * - integer*4 function GET_SYM(ok) + integer(kind=4) function GET_SYM(ok) include 'DIFFaX.par' include 'DIFFaX.inc' * @@ -2687,8 +2689,8 @@ C 401 format(1x, g12.5) logical diad, triad, tetrad, hexad logical TST_ROT, TST_MIR logical cell90, cell120, eq_sides - integer*4 idum, rot_sym - real*8 tmp_var + integer(kind=4) idum, rot_sym + real(kind=8) tmp_var * * external functions external TST_ROT, TST_MIR @@ -2893,10 +2895,10 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 th2_low + real(kind=8) th2_low * - integer*4 i, j, n_low, n_high, m - real*8 k1, k2, k3, const, gss, std_dev, tmp, tmp1, tmp2 + integer(kind=4) i, j, n_low, n_high, m + real(kind=8) k1, k2, k3, const, gss, std_dev, tmp, tmp1, tmp2 * if(FWHM.le.ZERO) goto 999 std_dev = FWHM / sqrt(EIGHT * log(TWO)) @@ -2978,18 +2980,18 @@ C 401 format(1x, g12.5) * GLQ16 returns the integrated value. * ______________________________________________________________________ * - real*8 function GLQ16(h, k, a, b, ok) + real(kind=8) function GLQ16(h, k, a, b, ok) include 'DIFFaX.par' include 'DIFFaX.inc' * logical ok - integer*4 h, k - real*8 a, b + integer(kind=4) h, k + real(kind=8) a, b * logical o, too_close - real*8 INTENS, INTEN2 - real*8 c1, c2, x1, x2, x3, x4, x5, x6, x7, x8 - real*8 w1, w2, w3, w4, w5, w6, w7, w8 + real(kind=8) INTENS, INTEN2 + real(kind=8) c1, c2, x1, x2, x3, x4, x5, x6, x7, x8 + real(kind=8) w1, w2, w3, w4, w5, w6, w7, w8 * parameter (x1 = 0.095012509837637440185D0) parameter (x2 = 0.281603550779258913230D0) @@ -3009,15 +3011,15 @@ C 401 format(1x, g12.5) parameter (w7 = 0.062253523938647892863D0) parameter (w8 = 0.027152459411754094852D0) * - integer*4 i, j + integer(kind=4) i, j * f is approximated by a polynomial of order (n-1) - integer*4 n + integer(kind=4) n parameter (n = 3) - integer*4 list(n) + integer(kind=4) list(n) * - real*8 Q2, l - real*8 ag_l(16), samp_l(n) - complex*16 f(MAX_L,16) + real(kind=8) Q2, l + real(kind=8) ag_l(16), samp_l(n) + complex(kind=8) f(MAX_L,16) * * external functions external INTENS, INTEN2 @@ -3166,8 +3168,8 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 HKLUP - real*8 y + integer(kind=4) HKLUP + real(kind=8) y * * HKLUP returns the maximum value of h, k or l given 'max_angle' HKLUP(y) = int(TWO * sin(HALF*max_angle) / (lambda*sqrt(y))) @@ -3217,13 +3219,13 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 FN + real(kind=8) FN logical ok * logical divided - integer*4 h, k - real*8 l0, l1, max_th, x, W4, ANGLE, theta, l, S, Q2 - real*8 t1, sum, tmp, LL, fact, d_th, l_tmp + integer(kind=4) h, k + real(kind=8) l0, l1, max_th, x, W4, ANGLE, theta, l, S, Q2 + real(kind=8) t1, sum, tmp, LL, fact, d_th, l_tmp * * external function, passed by reference external FN @@ -3360,18 +3362,18 @@ C 401 format(1x, g12.5) * INTEN2 returns the intensity at h, k, l * ______________________________________________________________________ * - real*8 function INTEN2(f, h, k, l, ok) + real(kind=8) function INTEN2(f, h, k, l, ok) include 'DIFFaX.par' include 'DIFFaX.inc' * logical ok - integer*4 h, k - real*8 l - complex*16 f(MAX_L) + integer(kind=4) h, k + real(kind=8) l + complex(kind=8) f(MAX_L) * - integer*4 i, j, m - real*8 twopi_l, dot, tmp - complex*16 phi(MAX_L, MAX_L), z, z_to_n + integer(kind=4) i, j, m + real(kind=8) twopi_l, dot, tmp + complex(kind=8) phi(MAX_L, MAX_L), z, z_to_n * twopi_l = PI2 * l * @@ -3450,19 +3452,19 @@ C 401 format(1x, g12.5) * INTENS returns the intensity at h, k, l * ______________________________________________________________________ * - real*8 function INTENS(f, h, k, l, ok) + real(kind=8) function INTENS(f, h, k, l, ok) include 'DIFFaX.par' include 'DIFFaX.inc' * logical ok - integer*4 h, k - real*8 l - complex*16 f(MAX_L) + integer(kind=4) h, k + real(kind=8) l + complex(kind=8) f(MAX_L) * logical GET_S, GET_S2 - integer*4 i - real*8 sum, x - complex*16 s(MAX_L) + integer(kind=4) i + real(kind=8) sum, x + complex(kind=8) s(MAX_L) * * external function external GET_S, GET_S2 @@ -3524,12 +3526,12 @@ C 401 format(1x, g12.5) * LENGTH returns the string length. * ______________________________________________________________________ * - integer*4 function LENGTH(string) + integer(kind=4) function LENGTH(string) implicit none * character string*(*) * - integer*4 i + integer(kind=4) i * i = index(string,' ') if(i.eq.0) then @@ -3564,10 +3566,10 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 th2_low + real(kind=8) th2_low * - integer*4 i, j, n_low, n_high - real*8 k1, k2, k3, const, lrnz, tmp, tmp1, tmp2 + integer(kind=4) i, j, n_low, n_high + real(kind=8) k1, k2, k3, const, lrnz, tmp, tmp1, tmp2 * if(FWHM.le.ZERO) goto 999 * check that cut-off is reasonable @@ -3643,11 +3645,11 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' * save * - integer*4 n, MAX_N, index(MAX_N) - real*8 a(MAX_N,MAX_N), b(MAX_N) + integer(kind=4) n, MAX_N, index(MAX_N) + real(kind=8) a(MAX_N,MAX_N), b(MAX_N) * - integer*4 i, i2, j, row - real*8 sum + integer(kind=4) i, i2, j, row + real(kind=8) sum * i2 = 0 do 20 i = 1, n @@ -3679,7 +3681,7 @@ C 401 format(1x, g12.5) * "Numerical Recipes: The Art of Scientific Computing." * Date: 18 Aug 1988 * Description: This is an LU decomposition routine, and accepts -* real*8 variables. +* real(kind=8) variables. * Given an n x n matrix a, with physical dimension MAX_N, this * routine replaces it by the LU decomposition of a rowwise permutation * of itself. a and n are input. a is the LU decomposed output; index @@ -3707,12 +3709,12 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' * save * - integer*4 n, MAX_N, index(MAX_N) - real*8 a(MAX_N,MAX_N), Det + integer(kind=4) n, MAX_N, index(MAX_N) + real(kind=8) a(MAX_N,MAX_N), Det * - integer*4 L_MAX, i, j, m, row + integer(kind=4) L_MAX, i, j, m, row parameter (L_MAX = 100) - real*8 tiny, tmp(L_MAX), sum, max, tmp2 + real(kind=8) tiny, tmp(L_MAX), sum, max, tmp2 parameter (tiny = 1.0D-20) * LUDCMP = .false. @@ -3804,15 +3806,15 @@ C 401 format(1x, g12.5) * be found at. * ______________________________________________________________________ * - real*8 function L_STEP(ok) + real(kind=8) function L_STEP(ok) include 'DIFFaX.par' include 'DIFFaX.inc' * logical ok * - real*8 tmp, z_step + real(kind=8) tmp, z_step logical YRDSTK, resonant, decided - integer*4 i1, i2, i3, i4 + integer(kind=4) i1, i2, i3, i4 * * external function external YRDSTK @@ -4031,11 +4033,11 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' * save * - integer*4 n - complex*16 a(MAX_L,MAX_L), b(MAX_L,MAX_L) + integer(kind=4) n + complex(kind=8) a(MAX_L,MAX_L), b(MAX_L,MAX_L) * - integer*4 i, j, m - complex*16 c(MAX_L,MAX_L), ctmp + integer(kind=4) i, j, m + complex(kind=8) c(MAX_L,MAX_L), ctmp * * first copy a into c do 10 j = 1, n @@ -4092,10 +4094,10 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - complex*16 a(MAX_L,MAX_L) + complex(kind=8) a(MAX_L,MAX_L) * - integer*4 i, j - complex*16 tmp_mat(MAX_L,MAX_L,MAX_BIN) + integer(kind=4) i, j + complex(kind=8) tmp_mat(MAX_L,MAX_L,MAX_BIN) * * external subroutine (Some compilers need them declared external) external MATSQR, MATMUL @@ -4144,11 +4146,11 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' * save * - integer*4 n - complex*16 a(MAX_L,MAX_L), b(MAX_L,MAX_L) + integer(kind=4) n + complex(kind=8) a(MAX_L,MAX_L), b(MAX_L,MAX_L) * - integer*4 i, j, m - complex*16 ctmp + integer(kind=4) i, j, m + complex(kind=8) ctmp * do 10 j = 1, n do 20 i = 1, n @@ -4183,7 +4185,7 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 i, j + integer(kind=4) i, j * do 10 i = 1, n_actual do 20 j = 1, l_n_atoms(i) @@ -4231,9 +4233,9 @@ C 401 format(1x, g12.5) * character*31 sym_fnam logical EQUALB, BINPOW, GET_G - integer*4 GET_SYM, i, j, j2, m, n, LENGTH - real*8 HKANGL, h_val, k_val - real*8 x, error, tmp, incr, z, old_lambda + integer(kind=4) GET_SYM, i, j, j2, m, n, LENGTH + real(kind=8) HKANGL, h_val, k_val + real(kind=8) x, error, tmp, incr, z, old_lambda logical did_it(MAX_L,MAX_L) * * external functions @@ -4580,11 +4582,11 @@ C 401 format(1x, g12.5) * logical invert character*33 txt - integer*4 i, j, m, n, nn, j2, err_no, max_err, fact, at_num - integer*4 PRUNE + integer(kind=4) i, j, m, n, nn, j2, err_no, max_err, fact, at_num + integer(kind=4) PRUNE parameter(max_err = 100) - real*8 lay(3,2*MAX_A) - real*8 x1, y1, z1, x2, y2, z2, sum_occ, tol, tmp, BOUNDS + real(kind=8) lay(3,2*MAX_A) + real(kind=8) x1, y1, z1, x2, y2, z2, sum_occ, tol, tmp, BOUNDS parameter(tol = eps1) * * external functions @@ -4698,16 +4700,16 @@ C 401 format(1x, g12.5) * PNTINT returns the intensity at h, k, l * ______________________________________________________________________ * - real*8 function PNTINT(h, k, l, ok) + real(kind=8) function PNTINT(h, k, l, ok) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 h, k - real*8 l + integer(kind=4) h, k + real(kind=8) l logical ok * - real*8 S, ANGLE, W4, INTENS, INTEN2, theta, x - complex*16 f(MAX_L) + real(kind=8) S, ANGLE, W4, INTENS, INTEN2, theta, x + complex(kind=8) f(MAX_L) * * external functions external INTENS, INTEN2 @@ -4773,15 +4775,15 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' * save * - integer*4 n - real*8 x, xa(n) - complex*16 ya(n), dy, y + integer(kind=4) n + real(kind=8) x, xa(n) + complex(kind=8) ya(n), dy, y logical ok * - integer*4 NMAX, i, m, ns + integer(kind=4) NMAX, i, m, ns parameter (NMAX = 10) - real*8 dif, dift, ho, hp - complex*16 c(NMAX), d(NMAX), w, den + real(kind=8) dif, dift, ho, hp + complex(kind=8) c(NMAX), d(NMAX), w, den * ns = 1 dif = abs(x - xa(1)) @@ -4847,10 +4849,10 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 h, k + integer(kind=4) h, k * - real*8 dot - integer*4 i, j + real(kind=8) dot + integer(kind=4) i, j * * Set up matrix that represents the sequences * For the matrix inversion routines, 'mat' and 'mat1' have to be @@ -4906,13 +4908,13 @@ C 401 format(1x, g12.5) * if there was an error. * ______________________________________________________________________ * - integer*4 function PRUNE(line) + integer(kind=4) function PRUNE(line) include 'DIFFaX.par' * save * character*(*) line * - integer*4 lin_len, i + integer(kind=4) lin_len, i * PRUNE = 0 * @@ -4956,11 +4958,11 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 th2_low + real(kind=8) th2_low * - integer*4 i, j, n_low, n_high, indx - real*8 th_rng, tn_th, c00, hk_inv, th0 - real*8 k1, k2, k3, k4, k5, pVoigt, const, tmp, speci + integer(kind=4) i, j, n_low, n_high, indx + real(kind=8) th_rng, tn_th, c00, hk_inv, th0 + real(kind=8) k1, k2, k3, k4, k5, pVoigt, const, tmp, speci * * first check the numbers if(pv_u.eq.ZERO .and. pv_v.eq.ZERO .and. pv_w.eq.ZERO) goto 990 @@ -5031,7 +5033,7 @@ C 401 format(1x, g12.5) * Date: Copyright (C) 1985 * Returns a uniform random deviate between 0.0 and 1.0. Set 'idum' * to any negative value to initialize or reinitialize the sequence. -* This version is modified to return real*8 values, and enforces static +* This version is modified to return real(kind=8) values, and enforces static * storage of all local variables by use of the 'save' statement * (In fact 'seed' is the important variable to save, but we save all * anyway). @@ -5042,17 +5044,17 @@ C 401 format(1x, g12.5) * RAN3 returns a real random number between 0 and 1 * ______________________________________________________________________ * - real*8 function RAN3(idum) + real(kind=8) function RAN3(idum) implicit none save * - integer*4 idum + integer(kind=4) idum * - real*8 big, seed, mz, fac + real(kind=8) big, seed, mz, fac parameter (big=4000000.0D0,seed=1618033.0D0,mz=0.0D0,fac=2.5D-7) - real*8 ma(55) - real*8 mj, mk - integer*4 iff, ii, i, j, inext, inextp + real(kind=8) ma(55) + real(kind=8) mj, mk + integer(kind=4) iff, ii, i, j, inext, inextp * data iff /0/ * @@ -5122,11 +5124,11 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 h, k - real*8 d_l + integer(kind=4) h, k + real(kind=8) d_l * logical ok - real*8 S, PNTINT, ANGLE, LL, l, i1, i2, x, theta, l_next + real(kind=8) S, PNTINT, ANGLE, LL, l, i1, i2, x, theta, l_next * * external subroutine (Some compilers need them declared external) * external GET_F @@ -5193,13 +5195,13 @@ C 401 format(1x, g12.5) include 'DIFFaX.inc' * save * - integer*4 arrsize - real*8 array(arrsize), sigma + integer(kind=4) arrsize + real(kind=8) array(arrsize), sigma logical ok * - integer*4 m, i, j - real*8 tmparr(SADSIZE) - real*8 k1, k2, tmp, tmp1, tmp2, gss, normalize + integer(kind=4) m, i, j + real(kind=8) tmparr(SADSIZE) + real(kind=8) k1, k2, tmp, tmp1, tmp2, gss, normalize * if(sigma.eq.ZERO) return * @@ -5289,7 +5291,7 @@ C 401 format(1x, g12.5) * is close to zero. Miniscule intensity variations can appear to be * huge relative to zero! * This function is needed in order to obtain a (crude) estimate of -* which intensity values are too small to worry about, even if the +* which intensity values are too small to worry about, even if the * relative intensity variations seem to be large. * This function will be of no use if there are no streaks, that is, * if the crystal is perfect. @@ -5312,9 +5314,9 @@ C 401 format(1x, g12.5) * logical ok * - integer*4 i, h, k, idum - real*8 RAN3, PNTINT, S, ANGLE - real*8 l, tot_int + integer(kind=4) i, h, k, idum + real(kind=8) RAN3, PNTINT, S, ANGLE + real(kind=8) l, tot_int * * external functions external RAN3, PNTINT @@ -5328,7 +5330,7 @@ C 401 format(1x, g12.5) idum = -1 * * First define angular range to sample. h_bnd, k_bnd, l_bnd -* (defined in HKL_LIM) and max_angle, are used later on +* (defined in HKL_LIM) and max_angle, are used later on * in GET_SYM and CHK_SYM. max_angle = QUARTER * PI call HKL_LIM() @@ -5384,9 +5386,9 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - real*8 th2_low + real(kind=8) th2_low * - integer*4 i, i_min, i_max + integer(kind=4) i, i_min, i_max * i_max = int(HALF*(th2_max - th2_min) / d_theta) + 1 * spec(1) corresponds to the intensity at the origin and is always zero. @@ -5447,15 +5449,15 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 mir_sym, idum + integer(kind=4) mir_sym, idum logical ok * logical is_good, match, eq_sides - integer*4 i, h, k, h_tmp, k_tmp + integer(kind=4) i, h, k, h_tmp, k_tmp logical cell90, cell120 - real*8 RAN3, PNTINT, S, ANGLE - real*8 tiny, l - real*8 i_avg, tol, i1, i2, variance, rel_var + real(kind=8) RAN3, PNTINT, S, ANGLE + real(kind=8) tiny, l + real(kind=8) i_avg, tol, i1, i2, variance, rel_var parameter (tiny = FIVE * eps4) * * external functions @@ -5712,14 +5714,14 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 rot_sym, idum + integer(kind=4) rot_sym, idum logical ok * logical is_good, match - integer*4 i, h, k, h_tmp, k_tmp - real*8 RAN3, PNTINT, S, ANGLE - real*8 l, i_avg, tol - real*8 i1, i2, i3, i4, variance, rel_var + integer(kind=4) i, h, k, h_tmp, k_tmp + real(kind=8) RAN3, PNTINT, S, ANGLE + real(kind=8) l, i_avg, tol + real(kind=8) i1, i2, i3, i4, variance, rel_var * * external functions external RAN3, PNTINT @@ -5951,9 +5953,9 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' include 'DIFFaX.inc' * - integer*4 h, k + integer(kind=4) h, k * - integer*4 i, m + integer(kind=4) i, m * do 10 m = 1, n_actual do 20 i = 1, l_n_atoms(m) @@ -5982,10 +5984,10 @@ C 401 format(1x, g12.5) include 'DIFFaX.par' * save * - real*8 x, y + real(kind=8) x, y logical ok * - real*8 tmp + real(kind=8) tmp * YRDSTK = .false. if(y.eq.ZERO) goto 999 diff --git a/sources/convcell.f b/sources/convcell.f index b0a79c89f..defa21199 100644 --- a/sources/convcell.f +++ b/sources/convcell.f @@ -1,7 +1,7 @@ C*********************************************************************** -C +C C----- PROGRAM TO EXPAND A REDUCED CELL TO A CONVENTIONAL CELL -C +C REAL DEGRAD PARAMETER (DEGRAD = 57.295779) @@ -11,46 +11,46 @@ integer icell CHARACTER*1 ICENTER - INTEGER*2 UX1(44)/ 1, 1, 1, 1, 1, 0, 1,-1, 1, 1, 1, 1, 1, 1, - 1 1,-1,-1, 0,-1, 0, 0, 0, 0, 1, 0, 1, 0,-1,1, 0, 1, 1, - 2 1,-1, 0, 1, 1,-1,-1, 0, 0,-1,-1, 1/ - INTEGER*2 VX1(44) /-1,-1, 0,-1, 0, 1, 0,-1, 0, 1, 0, 0, 1, 1, - 1 0,-1, 0,-1, 0, 1, 1, 1, 1, 2, 1, 0,-1, 0, 0, 1, 0, 0, - 2 0, 0,-1, 0, 0, 0,-2,-1,-1, 0,0, 0/ - INTEGER*2 WX1(44) / 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1 0, 0,-1, 1, 0, 1, 0, 0, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, - 2 0, 0, 0, 0, 2, 0, 0, 0,-2, 0, 0, 0/ - INTEGER*2 UX2(44) / 1,-1, 0,-1, 1, 1, 1,-1,-1, 1, 0, 0,-1,-1, - 1 0, 1,-1, 1, 0, 0, 0, 0, 0, 0, 0,-1,-1,-1, 1, 0, 0, 0, - 2 0, 0,-1,-1, 1, 1,-1, 0, 0, 0,-1, 0/ - INTEGER*2 VX2(44) / 1, 0, 1, 0, 1, 0, 1, 0, 1,-1, 1, 1, 1, 1, - 1 1,-1,-1,-1,-1, 1, 0, 0,-1,-1,-1, 2, 0, 0,-2, 1, 1, 1, - 2 1, 0, 0, 0, 0, 2, 0, 1,-1,-1,-1, 1/ - INTEGER*2 WX2(44) /-1, 1, 0, 1, 0, 1, 0,-1, 0, 0, 0, 0, 0, 0, - 1 0, 0, 0,-1, 1,-1, 1, 1, 1, 1, 1, 0, 0, 2, 0,-2, 0, 0, - 2 0,-1, 0,-2, 0, 0, 0, 2, 0, 0,-2, 0/ - INTEGER*2 UX3(44) /-1,-1, 0,-1, 0, 1, 0, 0,-1, 0, 0, 0, 0, 0, - 1 1, 1, 0, 1,-1,-1, 1, 1, 1, 1, 1,-1, 1, 0, 0,-1, 0, 0, - 2 0, 0, 0, 0, 0, 0, 0,-1,-1, 1, 0, 0/ - INTEGER*2 VX3(44) / 1,-1, 0,-1, 1, 1, 1,-1,-1, 0, 0, 0, 0, 0, - 1 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0,-1, 1, 0, 0, 0, 0, - 2 0,-1, 0, 1, 1, 0, 0, 0, 0, 1,-1, 0/ - INTEGER*2 WX3(44) / 1,-1, 1,-1, 1, 0, 1,-1, 3,-1, 1, 1, 1, 1, - 1 2, 2, 1, 0, 1, 0, 0, 0, 0, 0, 0, 2,-1, 0,-1, 0, 1, 1, - 2 1, 0,-1, 0, 0,-1,-1, 0, 0, 2, 0, 1/ + INTEGER(kind=2) UX1(44)/ 1, 1, 1, 1, 1, 0, 1,-1, 1, 1, 1, 1, + 1 1, 1, 1,-1,-1, 0,-1, 0, 0, 0, 0, 1, 0, 1, 0,-1,1, 0, + 2 1, 1, 1,-1, 0, 1, 1,-1,-1, 0, 0,-1,-1, 1/ + INTEGER(kind=2) VX1(44) /-1,-1, 0,-1, 0, 1, 0,-1, 0, 1, 0, 0, + 1 1, 1, 0,-1, 0,-1, 0, 1, 1, 1, 1, 2, 1, 0,-1, 0, 0, 1, + 2 0, 0, 0, 0,-1, 0, 0, 0,-2,-1,-1, 0,0, 0/ + INTEGER(kind=2) WX1(44) / 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, + 1 0, 0, 0, 0,-1, 1, 0, 1, 0, 0, 1, 1, 1, 0, 1, 0, 0, 0, + 2 0, 0, 0, 0, 0, 0, 2, 0, 0, 0,-2, 0, 0, 0/ + INTEGER(kind=2) UX2(44) / 1,-1, 0,-1, 1, 1, 1,-1,-1, 1, 0, 0, + 1 -1, -1, 0, 1,-1, 1, 0, 0, 0, 0, 0, 0, 0,-1,-1,-1, 1, + 2 0, 0, 0, 0, 0,-1,-1, 1, 1,-1, 0, 0, 0,-1, 0/ + INTEGER(kind=2) VX2(44) / 1, 0, 1, 0, 1, 0, 1, 0, 1,-1, 1, 1, + 1 1, 1, 1,-1,-1,-1,-1, 1, 0, 0,-1,-1,-1, 2, 0, 0,-2, 1, + 2 1, 1, 1, 0, 0, 0, 0, 2, 0, 1,-1,-1,-1, 1/ + INTEGER(kind=2) WX2(44) /-1, 1, 0, 1, 0, 1, 0,-1, 0, 0, 0, 0, + 1 0, 0, 0, 0, 0,-1, 1,-1, 1, 1, 1, 1, 1, 0, 0, 2, 0,-2, + 2 0, 0, 0,-1, 0,-2, 0, 0, 0, 2, 0, 0,-2, 0/ + INTEGER(kind=2) UX3(44) /-1,-1, 0,-1, 0, 1, 0, 0,-1, 0, 0, 0, + 1 0, 0, 1, 1, 0, 1,-1,-1, 1, 1, 1, 1, 1,-1, 1, 0, 0,-1, + 2 0, 0, 0, 0, 0, 0, 0, 0, 0,-1,-1, 1, 0, 0/ + INTEGER(kind=2) VX3(44) / 1,-1, 0,-1, 1, 1, 1,-1,-1, 0, 0, 0, + 1 0, 0, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0,-1, 1, 0, 0, + 2 0, 0, 0,-1, 0, 1, 1, 0, 0, 0, 0, 1,-1, 0/ + INTEGER(kind=2) WX3(44) / 1,-1, 1,-1, 1, 0, 1,-1, 3,-1, 1, 1, + 1 1, 1, 2, 2, 1, 0, 1, 0, 0, 0, 0, 0, 0, 2,-1, 0,-1, 0, + 2 1, 1, 1, 0,-1, 0, 0,-1,-1, 0, 0, 2, 0, 1/ C----- C-----SET THE INPUT AND OUTPUT UNIT NUMBERS ! DATA NTIN/3/ DATA NTOUT/6/ C---------------------------------------------------------------------- -C +C C-----SET APPROXIMATE ERROR WINDOW FOR ANGLES NEAR 90.00 -C +C DEL=0.05 Q=0.004 -C +C C-----TRANSFER THE REDUCED CELL TO LOCAL VARIABLES -C +C ! OPEN(UNIT=0,STATUS='OLD') READ(5,6900,END=800) AI, BI, CI, ALPI, BETI, GAMI 6900 FORMAT(6F10.0) @@ -61,12 +61,12 @@ ALPHR = ALPI BETR = BETI GAMR = GAMI -C +C C-----SET ANGLES OF 90.0+/-DEL TO 90.0 C-----RESETTING THESE ANGLES IS PERFORMED IN ORDER THAT THE A*B DOT C-----PRODUCTS CALCULATE TO ZERO WHEN THE ANGLE IS 90.0 WITHIN C-----A REASONABLE ERROR. -C +C IF(ALPHR.GT.90.0-DEL .AND. ALPHR.LT.90.0+DEL) ALPHR=90.0 IF(BETR .GT.90.0-DEL .AND. BETR .LT.90.0+DEL) BETR =90.0 IF(GAMR .GT.90.0-DEL .AND. GAMR .LT.90.0+DEL) GAMR =90.0 @@ -97,9 +97,9 @@ UZ3=UX3(L) VZ3=VX3(L) WZ3=WX3(L) -C +C C-----SET ICENTER TO THE METRIC SYMMETRY BASED ON THE REDUCED CELL # -C +C IF (ISEQ.EQ.1) THEN ICELL = 1 ICENTER ='F' @@ -150,43 +150,43 @@ ICENTER ='P' ENDIF C---------------------------------------------------------------------- -C +C C-----RESET THE REDUCED CELL ANGLES TO THE TRUE VALUES NOW THAT THE -C-----METRIC SYMMETRY HAS BEEN DETERMINED. -C +C-----METRIC SYMMETRY HAS BEEN DETERMINED. +C AR=ALPI/DEGRAD BR=BETI/DEGRAD GR=GAMI/DEGRAD -C +C C----CALC. LENGTH OF A VECTOR(A)(BRAVAIS FINAL) SQRT(A DOT A) CALL SYMDOT(UZ1,VZ1,WZ1,UZ1,VZ1,WZ1,ARI,BRI,CRI,AR,BR,GR,DOTAA) AZF=SQRT(DOTAA) -C +C C-----CALC. LENGTH OF VECTOR(B)(BRAVAIS FINAL)SQRT(B DOT B) -C +C CALL SYMDOT(UZ2,VZ2,WZ2,UZ2,VZ2,WZ2,ARI,BRI,CRI,AR,BR,GR,DOTBB) BZF=SQRT(DOT BB) -C +C C----CALC. LENGTH OF VECTOR(C)(BRAVAIS FINAL) SQRT(C DOT C) -C +C CALL SYMDOT(UZ3,VZ3,WZ3,UZ3,VZ3,WZ3,ARI,BRI,CRI,AR,BR,GR,DOTCC) CZF=SQRT(DOTCC) -C +C C-----CALC. ANGLE BETWEEN AZF AND BZF(ANGLE GAMMA) CALL SYMDOT(UZ1,VZ1,WZ1,UZ2,VZ2,WZ2,ARI,BRI,CRI,AR,BR,GR,DOTAB) COSG=DOTAB/(AZF*BZF) AGAM=ACOS(COSG) AGAMD=AGAM*DEGRAD -C +C C----CALC. ANGLE BETWEEN AZF AND CZF(ANGLE BETA) -C +C CALL SYMDOT(UZ1,VZ1,WZ1,UZ3,VZ3,WZ3,ARI,BRI,CRI,AR,BR,GR,DOTAC) COSB=DOTAC/(AZF*CZF) ABET=ACOS(COSB) ABETD=ABET*DEGRAD -C +C C------CALC. ANGLE BETWEEN BZF AND CZF(ANGLE ALPHA) -C +C CALL SYMDOT(UZ2,VZ2,WZ2,UZ3,VZ3,WZ3,ARI,BRI,CRI,AR,BR,GR,DOTBC) COSA=DOTBC/(BZF*CZF) AALP=ACOS(COSA) @@ -201,20 +201,20 @@ 800 CONTINUE end C====================================================================== - SUBROUTINE SYMTST(NTOUT, IWARN, ISEQ, Q, E, + SUBROUTINE SYMTST(NTOUT, IWARN, ISEQ, Q, E, 1 ARI, BRI, CRI, ALPHR, BETR, GAMR) REAL E(6), Q -C +C C-----SYMTST TESTS FOR EQUALITY OF DOT PRODUCTS BASED ON DIFFERENCES C-----BEING SMALLER THAT A PRESET VALUE FOR THE RELATIVE ERROR IN A*A C-----B*B, C*C, B*C, A*C OR A*B. -C +C C-----THE RELATIVE ERROR Q IS SET TO 0.004 IN SUBROUTINE SYM C-----THE INCREMENT DQ INSURES THAT Q*E>0 NEAR 90 DEG -C -C +C +C ISEQ=0 DQ=0.04 ISEQ=0 @@ -225,7 +225,7 @@ SUBROUTINE SYMTST(NTOUT, IWARN, ISEQ, Q, E, NEG=-1 elseIF(E(4).GT.Q.AND.E(5).GT.Q.AND.E(6).GE.Q) then NEG=0 - else + else NEG=-1 IF(ALPHR.LT.89.99.OR.BETR.LT.89.99.OR.GAMR.LT.89.99)NEG=0 IWARN=IWARN+1 @@ -234,9 +234,9 @@ SUBROUTINE SYMTST(NTOUT, IWARN, ISEQ, Q, E, endif C-----TEST FOR A=B=C ------------------------------------------------------ IF(ABS(E(1)-E(3)) .LT. Q*E(3)) THEN -C +C C-----REDUCED FORM WITH A=B=C (NUMBERS 1 TO 8) ------------------------- -C +C IF(NEG.NE.-1) THEN X=E(1)/2. IF (ABS(E(4)-X).LT.(E(4)*Q+DQ).AND.ABS(E(5)-X).LT.(E(5)*Q+DQ) @@ -272,9 +272,9 @@ SUBROUTINE SYMTST(NTOUT, IWARN, ISEQ, Q, E, ENDIF C-----TEST FOR A=B -------------------------------------------------------- IF(ABS(E(1)-E(2)) .LT. Q*E(2)) THEN -C +C C-----REDUCED FORMS WITH A=B (NUMBERS 9 TO 17) -------------------------- -C +C IF(NEG.NE.-1) THEN X=E(1)/2. IF(ABS(E(4)-X).LT.(E(4)*Q+DQ).AND.ABS(E(5)-X).LT.(E(5)*Q+DQ) @@ -308,11 +308,11 @@ SUBROUTINE SYMTST(NTOUT, IWARN, ISEQ, Q, E, ENDIF ENDIF C-----TEST FOR B=C ------------------------------------------------------ - IF(ABS(E(2)-E(3)) .LT. Q*E(3) .and. + IF(ABS(E(2)-E(3)) .LT. Q*E(3) .and. 1 ABS(BRI-CRI).LE.ABS(BRI*Q)) THEN -C +C C-----REDUCED FORMS WITH B=C (NUMBERS 18 TO 25) ---------------------- -C +C IF(NEG.NE.-1) THEN X=E(1)/2. IF (ABS(E(4)-X/2.).LT.(ABS(E(4)*Q)+DQ).AND. @@ -345,9 +345,9 @@ SUBROUTINE SYMTST(NTOUT, IWARN, ISEQ, Q, E, IF (ISEQ .NE. 0) RETURN ENDIF ENDIF -C +C C-----REDUCED FORMS WITH A.NE.B.NE.C (NUMBERS 26 TO 44) -C +C IF(NEG.NE.-1) THEN X=E(1)/2. Y=E(2)/2. @@ -409,7 +409,7 @@ SUBROUTINE SYMTST(NTOUT, IWARN, ISEQ, Q, E, RETURN END SUBROUTINE SYMDOT(UZ1,VZ1,WZ1,UZ2,VZ2,WZ2,XI,YI,ZI,AR,BR,GR,DOTXY) -C +C C-----DOT PRODUCT SUBROUTINE(X DOT Y) WHERE C-----VECTOR X=(UZ1A+VZ1B+WZ1C) C-------VECTOR Y=UZ2A+VZ2B+WZ2C) diff --git a/sources/histogram2d.for b/sources/histogram2d.for index ceac62dc1..5586b1c2d 100644 --- a/sources/histogram2d.for +++ b/sources/histogram2d.for @@ -20,16 +20,16 @@ Cf2py intent(in,out) hst Cf2py depend(nxbins,nybins) hst IMPLICIT NONE - INTEGER*8 N - REAL*4 X(0:N-1),Y(0:N-1),Z(0:N-1) - INTEGER*8 NXBINS,NYBINS - REAL*8 XLIM(0:1),YLIM(0:1) - REAL*4 NST(0:NXBINS-1,0:NYBINS-1) - REAL*4 HST(0:NXBINS-1,0:NYBINS-1) + INTEGER(kind=8) N + REAL(kind=4) X(0:N-1),Y(0:N-1),Z(0:N-1) + INTEGER(kind=8) NXBINS,NYBINS + REAL(kind=8) XLIM(0:1),YLIM(0:1) + REAL(kind=4) NST(0:NXBINS-1,0:NYBINS-1) + REAL(kind=4) HST(0:NXBINS-1,0:NYBINS-1) - INTEGER*4 I,J,K - REAL*8 DX,DY - REAL*4 DDX,DDY + INTEGER(kind=4) I,J,K + REAL(kind=8) DX,DY + REAL(kind=4) DDX,DDY DO K=0,N-1 C if ( mod(k,8000) .eq. 0 ) C 1 print *,k,x(k),xlim,y(k),ylim diff --git a/sources/histosigma2d.for b/sources/histosigma2d.for index 3a68473b5..512a658ba 100644 --- a/sources/histosigma2d.for +++ b/sources/histosigma2d.for @@ -24,18 +24,18 @@ Cf2py intent(in,out) qmat Cf2py depend(nxbins,nybins) qmat IMPLICIT NONE - INTEGER*8 N - REAL*4 X(0:N-1),Y(0:N-1),Z(0:N-1) - INTEGER*8 NXBINS,NYBINS - REAL*8 XLIM(0:1),YLIM(0:1) - REAL*4 NST(0:NXBINS-1,0:NYBINS-1) - REAL*4 HST(0:NXBINS-1,0:NYBINS-1) - REAL*4 AMAT(0:NXBINS-1,0:NYBINS-1) - REAL*4 QMAT(0:NXBINS-1,0:NYBINS-1) + INTEGER(kind=8) N + REAL(kind=4) X(0:N-1),Y(0:N-1),Z(0:N-1) + INTEGER(kind=8) NXBINS,NYBINS + REAL(kind=8) XLIM(0:1),YLIM(0:1) + REAL(kind=4) NST(0:NXBINS-1,0:NYBINS-1) + REAL(kind=4) HST(0:NXBINS-1,0:NYBINS-1) + REAL(kind=4) AMAT(0:NXBINS-1,0:NYBINS-1) + REAL(kind=4) QMAT(0:NXBINS-1,0:NYBINS-1) - INTEGER*4 I,J,K - REAL*8 DX,DY - REAL*4 DDX,DDY,AOLD + INTEGER(kind=4) I,J,K + REAL(kind=8) DX,DY + REAL(kind=4) DDX,DDY,AOLD DO K=0,N-1 IF ( ( X(K).GE.XLIM(0) .AND. X(K).LT.XLIM(1) ) .AND. 1 ( Y(K).GE.YLIM(0) .AND. Y(K).LT.YLIM(1) )) THEN diff --git a/sources/pack_f.for b/sources/pack_f.for index d333e3810..8b1d91b5a 100644 --- a/sources/pack_f.for +++ b/sources/pack_f.for @@ -9,11 +9,11 @@ Cf2py intent(in,out) IMG Cf2py depend(MX,MY) IMG IMPLICIT NONE - INTEGER*4 BITDECODE(0:7),SETBITS(0:16),IN,N,MX,MY,BITNUM - INTEGER*4 PIXEL,SPILLBITS,USEDBITS,VALIDS,WINDOW,TOTAL - INTEGER*4 IMG(0:MX-1,0:MY-1),NEXTINT - INTEGER*4 SPILL,ROW,COL,PIXNUM,MM1 - INTEGER*2 TMP + INTEGER(kind=4) BITDECODE(0:7),SETBITS(0:16),IN,N,MX,MY,BITNUM + INTEGER(kind=4) PIXEL,SPILLBITS,USEDBITS,VALIDS,WINDOW,TOTAL + INTEGER(kind=4) IMG(0:MX-1,0:MY-1),NEXTINT + INTEGER(kind=4) SPILL,ROW,COL,PIXNUM,MM1 + INTEGER(kind=2) TMP CHARACTER*1 CMPR(0:N-1) DATA BITDECODE /0,4,5,6,7,8,16,32/ DATA SETBITS /Z'0000',Z'0001',Z'0003',Z'0007', @@ -66,7 +66,7 @@ Cf2py depend(MX,MY) IMG SPILL = ICHAR(CMPR(IN)) IN = IN+1 SPILLBITS = 8 - END IF + END IF ELSE PIXNUM = PIXNUM-1 IF ( BITNUM .EQ. 0 ) THEN @@ -75,7 +75,7 @@ Cf2py depend(MX,MY) IMG NEXTINT = IAND(WINDOW,SETBITS(BITNUM)) VALIDS = VALIDS-BITNUM WINDOW = ISHFT(WINDOW,-BITNUM) - IF ( BTEST(NEXTINT,BITNUM-1) ) + IF ( BTEST(NEXTINT,BITNUM-1) ) 1 NEXTINT = IOR(NEXTINT,NOT(SETBITS(BITNUM))) END IF @@ -91,7 +91,7 @@ Cf2py depend(MX,MY) IMG 1 (IMG(COL-1,ROW)+IMG(0,ROW)+ 1 IMG(MM1,ROW-1)+IMG(MM1-1,ROW-1) +2)/4 ELSE - TMP = NEXTINT + + TMP = NEXTINT + 1 (IMG(COL-1,ROW)+IMG(COL+1,ROW-1)+ 1 IMG(COL,ROW-1)+IMG(COL-1,ROW-1) +2)/4 END IF @@ -104,18 +104,18 @@ Cf2py depend(MX,MY) IMG PIXEL = PIXEL+1 END IF END DO - END IF + END IF END DO DO ROW=0,MM1 DO COL=0,MM1 IF ( IMG(COL,ROW).LT.0 ) IMG(COL,ROW) = IMG(COL,ROW)+65536 END DO END DO - + RETURN END - + SUBROUTINE PACK_F3(N,CMPR,MX,MY,IMG) Cf2py intent(in) N @@ -127,12 +127,12 @@ Cf2py intent(in,out) IMG Cf2py depend(MX,MY) IMG IMPLICIT NONE - INTEGER*4 BITDECODE(0:7),SETBITS(0:16),IN,N,MX,MY,BITNUM - INTEGER*4 PIXEL,SPILLBITS,USEDBITS,VALIDS,WINDOW,TOTAL - INTEGER*4 IMG(0:MX-1,0:MY-1),NEXTINT - INTEGER*4 SPILL,ROW,COL,PIXNUM,MM1 - INTEGER*2 TMP - INTEGER*1 CMPR(0:N-1) + INTEGER(kind=4) BITDECODE(0:7),SETBITS(0:16),IN,N,MX,MY,BITNUM + INTEGER(kind=4) PIXEL,SPILLBITS,USEDBITS,VALIDS,WINDOW,TOTAL + INTEGER(kind=4) IMG(0:MX-1,0:MY-1),NEXTINT + INTEGER(kind=4) SPILL,ROW,COL,PIXNUM,MM1 + INTEGER(kind=2) TMP + INTEGER(kind=1) CMPR(0:N-1) DATA BITDECODE /0,4,5,6,7,8,16,32/ DATA SETBITS /Z'0000',Z'0001',Z'0003',Z'0007', 1 Z'000F',Z'001F',Z'003F',Z'007F',Z'00FF', @@ -184,7 +184,7 @@ Cf2py depend(MX,MY) IMG SPILL = ICHAR(CHAR(CMPR(IN))) IN = IN+1 SPILLBITS = 8 - END IF + END IF ELSE PIXNUM = PIXNUM-1 IF ( BITNUM .EQ. 0 ) THEN @@ -193,7 +193,7 @@ Cf2py depend(MX,MY) IMG NEXTINT = IAND(WINDOW,SETBITS(BITNUM)) VALIDS = VALIDS-BITNUM WINDOW = ISHFT(WINDOW,-BITNUM) - IF ( BTEST(NEXTINT,BITNUM-1) ) + IF ( BTEST(NEXTINT,BITNUM-1) ) 1 NEXTINT = IOR(NEXTINT,NOT(SETBITS(BITNUM))) END IF @@ -209,7 +209,7 @@ Cf2py depend(MX,MY) IMG 1 (IMG(COL-1,ROW)+IMG(0,ROW)+ 1 IMG(MM1,ROW-1)+IMG(MM1-1,ROW-1) +2)/4 ELSE - TMP = NEXTINT + + TMP = NEXTINT + 1 (IMG(COL-1,ROW)+IMG(COL+1,ROW-1)+ 1 IMG(COL,ROW-1)+IMG(COL-1,ROW-1) +2)/4 END IF @@ -222,14 +222,13 @@ Cf2py depend(MX,MY) IMG PIXEL = PIXEL+1 END IF END DO - END IF + END IF END DO DO ROW=0,MM1 DO COL=0,MM1 IF ( IMG(COL,ROW).LT.0 ) IMG(COL,ROW) = IMG(COL,ROW)+65536 END DO END DO - + RETURN END - diff --git a/sources/polymask.for b/sources/polymask.for index 893d4d7a5..156fba747 100644 --- a/sources/polymask.for +++ b/sources/polymask.for @@ -11,13 +11,13 @@ Cf2py depend(M) POLY Cf2py intent(in,out) MASK IMPLICIT NONE - INTEGER*4 N,M - REAL*4 X(0:N-1),Y(0:N-1) - REAL*8 POLY(0:M-1,0:1) + INTEGER(kind=4) N,M + REAL(kind=4) X(0:N-1),Y(0:N-1) + REAL(kind=8) POLY(0:M-1,0:1) LOGICAL*1 MASK(0:1024*1024-1) - INTEGER*4 I,K - REAL*4 P1X,P1Y,P2X,P2Y,XINTERS + INTEGER(kind=4) I,K + REAL(kind=4) P1X,P1Y,P2X,P2Y,XINTERS DO K=0,N-1 MASK(K) = .FALSE. diff --git a/sources/powsubs/acosd.for b/sources/powsubs/acosd.for index 4dcfc8087..d9a4d6d31 100644 --- a/sources/powsubs/acosd.for +++ b/sources/powsubs/acosd.for @@ -1,4 +1,4 @@ - REAL*4 FUNCTION ACOSD(ARG) + REAL(kind=4) FUNCTION ACOSD(ARG) !PURPOSE: @@ -6,7 +6,7 @@ !CALLING ARGUMENTS: - REAL*4 ARG + REAL(kind=4) ARG !INCLUDE STATEMENTS: diff --git a/sources/powsubs/cosd.for b/sources/powsubs/cosd.for index 44df78abd..eb3de0bb1 100644 --- a/sources/powsubs/cosd.for +++ b/sources/powsubs/cosd.for @@ -1,4 +1,4 @@ - REAL*4 FUNCTION COSD(ARG) + REAL(kind=4) FUNCTION COSD(ARG) !PURPOSE: Calculate cosine from angle in deg. @@ -6,7 +6,7 @@ !CALLING ARGUMENTS: - REAL*4 ARG !Cosine argument in degrees + REAL(kind=4) ARG !Cosine argument in degrees !INCLUDE STATEMENTS: diff --git a/sources/powsubs/epsvoigt.for b/sources/powsubs/epsvoigt.for index 28ea10d96..0f283a3aa 100644 --- a/sources/powsubs/epsvoigt.for +++ b/sources/powsubs/epsvoigt.for @@ -10,29 +10,29 @@ !CALLING ARGUMENTS: - REAL*4 DT !Delta-TOF from center - REAL*4 ALP !Exponential rise - REAL*4 BET !Exponential decay - REAL*4 SIG !Gaussian variance - REAL*4 GAM !Lorentzian FWHM - REAL*4 FUNC !Value of pseudo-Voigt at DX - REAL*4 DFDX !dF/dta - REAL*4 DFDA !dF/da - REAL*4 DFDB !dF/db - REAL*4 DFDS !dF/ds - REAL*4 DFDG !dF/dg + REAL(kind=4) DT !Delta-TOF from center + REAL(kind=4) ALP !Exponential rise + REAL(kind=4) BET !Exponential decay + REAL(kind=4) SIG !Gaussian variance + REAL(kind=4) GAM !Lorentzian FWHM + REAL(kind=4) FUNC !Value of pseudo-Voigt at DX + REAL(kind=4) DFDX !dF/dta + REAL(kind=4) DFDA !dF/da + REAL(kind=4) DFDB !dF/db + REAL(kind=4) DFDS !dF/ds + REAL(kind=4) DFDG !dF/dg !INCLUDE STATEMENTS: !LOCAL VARIABLES: - REAL*4 COFG(6),COFL(6) !Linear combination coeffs - REAL*4 ACOFG(7),ACOFL(7) - REAL*4 GNORM !Gaussian Normalization constant - REAL*4 COFT(6),COFN(3) - REAL*4 NORM !Normalization constant - REAL*4 RXA,IXA,RXB,IXB !Exp-integral arguements - REAL*4 RFA,IFA,RFB,IFB !Exp-integral results + REAL(kind=4) COFG(6),COFL(6) !Linear combination coeffs + REAL(kind=4) ACOFG(7),ACOFL(7) + REAL(kind=4) GNORM !Gaussian Normalization constant + REAL(kind=4) COFT(6),COFN(3) + REAL(kind=4) NORM !Normalization constant + REAL(kind=4) RXA,IXA,RXB,IXB !Exp-integral arguements + REAL(kind=4) RFA,IFA,RFB,IFB !Exp-integral results !SUBROUTINES CALLED: diff --git a/sources/powsubs/expint.for b/sources/powsubs/expint.for index 8cd4f005d..776caa020 100644 --- a/sources/powsubs/expint.for +++ b/sources/powsubs/expint.for @@ -9,22 +9,22 @@ !CALLING ARGUMENTS: - REAL*4 AX,AY !Real & imaginary parts of argument z - REAL*4 ANSX,ANSY !Real & imaginary parts of result + REAL(kind=4) AX,AY !Real & imaginary parts of argument z + REAL(kind=4) ANSX,ANSY !Real & imaginary parts of result !INCLUDE STATEMENTS: !LOCAL VARIABLES: - REAL*4 ZX,ZY - REAL*4 CLNX,CLNY - REAL*4 TEMX,TEMY - REAL*4 SUBX,SUBY - REAL*4 EULERX - REAL*4 ZANSX,ZANSY - REAL*4 DEDZX,DEDZY - REAL*4 RATX,RATY - REAL*4 ADDX,ADDY + REAL(kind=4) ZX,ZY + REAL(kind=4) CLNX,CLNY + REAL(kind=4) TEMX,TEMY + REAL(kind=4) SUBX,SUBY + REAL(kind=4) EULERX + REAL(kind=4) ZANSX,ZANSY + REAL(kind=4) DEDZX,DEDZY + REAL(kind=4) RATX,RATY + REAL(kind=4) ADDX,ADDY !SUBROUTINES CALLED: diff --git a/sources/powsubs/gauleg.for b/sources/powsubs/gauleg.for index 82e81f61a..babd02d14 100644 --- a/sources/powsubs/gauleg.for +++ b/sources/powsubs/gauleg.for @@ -7,8 +7,8 @@ c of intervals (N), this routine returns arrays X and W of length N, c containing the abscissas and weights of the Gauss-Legendre N-point c quadrature formula. c - implicit real*4 (a-h,o-z) - REAL*4 X1,X2,X(N),W(N) + implicit real(kind=4) (a-h,o-z) + REAL(kind=4) X1,X2,X(N),W(N) parameter (eps=3.e-7) C m=(n+1)/2 diff --git a/sources/powsubs/gerfc.for b/sources/powsubs/gerfc.for index 45609b88f..c0140dfc4 100644 --- a/sources/powsubs/gerfc.for +++ b/sources/powsubs/gerfc.for @@ -6,13 +6,13 @@ !CALLING ARGUMENTS: - REAL*4 Y ! - REAL*4 GERFC !Result + REAL(kind=4) Y ! + REAL(kind=4) GERFC !Result !INCLUDE STATEMENTS: DIMENSION P(5),Q(4),P1(9),Q1(8),P2(6),Q2(5) - REAL*4 P,Q,P1,Q1,P2,Q2,XMIN,XLARGE,SQRPI,X, + REAL(kind=4) P,Q,P1,Q1,P2,Q2,XMIN,XLARGE,SQRPI,X, 1 RES,XSQ,XNUM,XDEN,XI INTEGER ISW,I diff --git a/sources/powsubs/hfunc.for b/sources/powsubs/hfunc.for index cf6996caa..fd338616a 100644 --- a/sources/powsubs/hfunc.for +++ b/sources/powsubs/hfunc.for @@ -8,10 +8,10 @@ !CALLING ARGUMENTS: - REAL*4 X,Y !Arguments - INTEGER*4 IFLAG !Control for calculation method - REAL*4 DHDY !Partial derivative wrt y - REAL*4 HFUNC !Value of function + REAL(kind=4) X,Y !Arguments + INTEGER(kind=4) IFLAG !Control for calculation method + REAL(kind=4) DHDY !Partial derivative wrt y + REAL(kind=4) HFUNC !Value of function !INCLUDE STATEMENTS: @@ -21,7 +21,7 @@ !FUNCTION DEFINITIONS: - REAL*4 GERFC !Complementary error function + REAL(kind=4) GERFC !Complementary error function !DATA STATEMENTS: diff --git a/sources/powsubs/lorentz.for b/sources/powsubs/lorentz.for index 2e0160f73..eb3910e8f 100644 --- a/sources/powsubs/lorentz.for +++ b/sources/powsubs/lorentz.for @@ -8,11 +8,11 @@ !CALLING ARGUMENTS: - REAL*4 DT !Delta - REAL*4 GAM !Coefficient - REAL*4 FUNC !Function - REAL*4 DLDT !df/dt - REAL*4 DLDG !df/dg + REAL(kind=4) DT !Delta + REAL(kind=4) GAM !Coefficient + REAL(kind=4) FUNC !Function + REAL(kind=4) DLDT !df/dt + REAL(kind=4) DLDG !df/dg !INCLUDE STATEMENTS: diff --git a/sources/powsubs/psvfcjexpo.for b/sources/powsubs/psvfcjexpo.for index c382946f2..b8ad18424 100644 --- a/sources/powsubs/psvfcjexpo.for +++ b/sources/powsubs/psvfcjexpo.for @@ -14,91 +14,91 @@ !CALLING ARGUMENTS: - REAL*4 DTT !delta 2-theta in degrees - REAL*4 TTHETA !2-theta in degrees - REAL*4 ALP,BET,SIG,GAM - REAL*4 SL,HL !S/L & H/L - REAL*4 PRFUNC - REAL*4 DPRDT - REAL*4 ALPART,BEPART,SIGPART,GAMPART - REAL*4 SLPART,HLPART + REAL(kind=4) DTT !delta 2-theta in degrees + REAL(kind=4) TTHETA !2-theta in degrees + REAL(kind=4) ALP,BET,SIG,GAM + REAL(kind=4) SL,HL !S/L & H/L + REAL(kind=4) PRFUNC + REAL(kind=4) DPRDT + REAL(kind=4) ALPART,BEPART,SIGPART,GAMPART + REAL(kind=4) SLPART,HLPART !INCLUDE STATEMENTS: - REAL*4 SIND,COSD,TAND,ACOSD + REAL(kind=4) SIND,COSD,TAND,ACOSD !LOCAL VARIABLES: - REAL*4 R ! pseudo-voight intensity - REAL*4 DRDT ! deriv R w/r theta - REAL*4 DRDA ! deriv R w/r alpha - REAL*4 DRDB ! deriv R w/r beta - REAL*4 DRDS ! deriv R w/r sig - REAL*4 DRDG ! deriv R w/r gam - REAL*4 F - REAL*4 G - REAL*4 DFDA - REAL*4 DGDA - REAL*4 DGDB - REAL*4 DYDA - REAL*4 DYDB - REAL*4 SIN2THETA2 ! sin(2theta)**2 - REAL*4 COS2THETA ! cos(2theta) - REAL*4 SIN2THETA ! sin(2THETA) - REAL*4 SINDELTA ! sin(Delta) - REAL*4 COSDELTA ! cos(Delta) - REAL*4 RCOSDELTA ! 1/cos(Delta) - REAL*4 TANDELTA ! tan(Delta) - REAL*4 COSDELTA2 ! cos(Delta)**2 - REAL*4 A ! asym1 [coff(9)] - REAL*4 B ! asym2 [coff(10)] - REAL*4 APB ! (A+B) - REAL*4 AMB ! (A-B) - REAL*4 APB2 ! (A+B)**2 + REAL(kind=4) R ! pseudo-voight intensity + REAL(kind=4) DRDT ! deriv R w/r theta + REAL(kind=4) DRDA ! deriv R w/r alpha + REAL(kind=4) DRDB ! deriv R w/r beta + REAL(kind=4) DRDS ! deriv R w/r sig + REAL(kind=4) DRDG ! deriv R w/r gam + REAL(kind=4) F + REAL(kind=4) G + REAL(kind=4) DFDA + REAL(kind=4) DGDA + REAL(kind=4) DGDB + REAL(kind=4) DYDA + REAL(kind=4) DYDB + REAL(kind=4) SIN2THETA2 ! sin(2theta)**2 + REAL(kind=4) COS2THETA ! cos(2theta) + REAL(kind=4) SIN2THETA ! sin(2THETA) + REAL(kind=4) SINDELTA ! sin(Delta) + REAL(kind=4) COSDELTA ! cos(Delta) + REAL(kind=4) RCOSDELTA ! 1/cos(Delta) + REAL(kind=4) TANDELTA ! tan(Delta) + REAL(kind=4) COSDELTA2 ! cos(Delta)**2 + REAL(kind=4) A ! asym1 [coff(9)] + REAL(kind=4) B ! asym2 [coff(10)] + REAL(kind=4) APB ! (A+B) + REAL(kind=4) AMB ! (A-B) + REAL(kind=4) APB2 ! (A+B)**2 ! Intermediate variables - REAL*4 RSUMWG2 ! 1.0/(sum of w G)**2 - REAL*4 SUMWG ! sum of w G - REAL*4 WG ! w G - REAL*4 RSUMWG ! 1.0/sum of w G - REAL*4 SUMWRG ! sum of w G - REAL*4 SUMWDGDA ! sum of w dGdA - REAL*4 SUMWRDGDA ! sum of w R dGdA - REAL*4 SUMWDGDB ! sum of w dGdB - REAL*4 SUMWRDGDB ! sum of w R dGdB - REAL*4 SUMWGDRD2T ! sum of w G dRd(2theta) - REAL*4 SUMWGDRDALP ! sum of w G dRdp(n) - REAL*4 SUMWGDRDBET ! sum of w G dRdp(n) - REAL*4 SUMWGDRDSIG ! sum of w G dRdp(n) - REAL*4 SUMWGDRDGAM ! sum of w G dRdp(n) - REAL*4 SUMWGDRDA - REAL*4 SUMWGDRDB - REAL*4 EMIN ! 2phi minimum - REAL*4 EINFL ! 2phi of inflection point - REAL*4 DEMINDA ! Derivative of Emin wrt A - REAL*4 DELTA ! Angle of integration for convolution - REAL*4 DDELTADA - REAL*4 TMP,TMP1,TMP2 ! intermediates - INTEGER*4 I,K,IT ! Miscellaneous loop variables + REAL(kind=4) RSUMWG2 ! 1.0/(sum of w G)**2 + REAL(kind=4) SUMWG ! sum of w G + REAL(kind=4) WG ! w G + REAL(kind=4) RSUMWG ! 1.0/sum of w G + REAL(kind=4) SUMWRG ! sum of w G + REAL(kind=4) SUMWDGDA ! sum of w dGdA + REAL(kind=4) SUMWRDGDA ! sum of w R dGdA + REAL(kind=4) SUMWDGDB ! sum of w dGdB + REAL(kind=4) SUMWRDGDB ! sum of w R dGdB + REAL(kind=4) SUMWGDRD2T ! sum of w G dRd(2theta) + REAL(kind=4) SUMWGDRDALP ! sum of w G dRdp(n) + REAL(kind=4) SUMWGDRDBET ! sum of w G dRdp(n) + REAL(kind=4) SUMWGDRDSIG ! sum of w G dRdp(n) + REAL(kind=4) SUMWGDRDGAM ! sum of w G dRdp(n) + REAL(kind=4) SUMWGDRDA + REAL(kind=4) SUMWGDRDB + REAL(kind=4) EMIN ! 2phi minimum + REAL(kind=4) EINFL ! 2phi of inflection point + REAL(kind=4) DEMINDA ! Derivative of Emin wrt A + REAL(kind=4) DELTA ! Angle of integration for convolution + REAL(kind=4) DDELTADA + REAL(kind=4) TMP,TMP1,TMP2 ! intermediates + INTEGER(kind=4) I,K,IT ! Miscellaneous loop variables c c Local Variables for Gaussian Integration c - INTEGER*4 NGT !number of terms in Gaussian quadrature - INTEGER*4 NUMTAB ! number of pre-computed Gaussian tables + INTEGER(kind=4) NGT !number of terms in Gaussian quadrature + INTEGER(kind=4) NUMTAB ! number of pre-computed Gaussian tables PARAMETER (NUMTAB=34) - INTEGER*4 NTERMS(NUMTAB) ! number of terms in each table - must be even - INTEGER*4 FSTTERM(NUMTAB) ! location of 1st term: N.B. N/2 terms + INTEGER(kind=4) NTERMS(NUMTAB) ! number of terms in each table - must be even + INTEGER(kind=4) FSTTERM(NUMTAB) ! location of 1st term: N.B. N/2 terms LOGICAL*4 CALCLFG(NUMTAB) ! true if table has previously been calculated - INTEGER*4 ARRAYNUM ! number of selected array - INTEGER*4 ARRAYSIZE ! size of complete array + INTEGER(kind=4) ARRAYNUM ! number of selected array + INTEGER(kind=4) ARRAYSIZE ! size of complete array PARAMETER (ARRAYSIZE=1670) - REAL*4 XP(ARRAYSIZE) !Gaussian abscissas - REAL*4 WP(ARRAYSIZE) !Gaussian weights - REAL*4 XPT(400) !temporary Gaussian abscissas - REAL*4 WPT(400) !temporary Gaussian weights - REAL*4 STOFW + REAL(kind=4) XP(ARRAYSIZE) !Gaussian abscissas + REAL(kind=4) WP(ARRAYSIZE) !Gaussian weights + REAL(kind=4) XPT(400) !temporary Gaussian abscissas + REAL(kind=4) WPT(400) !temporary Gaussian weights + REAL(kind=4) STOFW PARAMETER (STOFW=2.35482005) - REAL*4 TODEG + REAL(kind=4) TODEG PARAMETER (todeg=57.2957795) SAVE CALCLFG,XP,WP !VALUES TO BE SAVED ACROSS CALLS diff --git a/sources/powsubs/psvfcjo.for b/sources/powsubs/psvfcjo.for index be246cb46..fdb058a94 100644 --- a/sources/powsubs/psvfcjo.for +++ b/sources/powsubs/psvfcjo.for @@ -14,88 +14,88 @@ !CALLING ARGUMENTS: - REAL*4 DTT !delta 2-theta in centidegrees - REAL*4 TTHETA !2-theta in centidegrees - REAL*4 SIG,GAM - REAL*4 SL,HL !S/L & H/L - REAL*4 PRFUNC - REAL*4 DPRDT - REAL*4 SIGPART,GAMPART - REAL*4 SLPART,HLPART + REAL(kind=4) DTT !delta 2-theta in centidegrees + REAL(kind=4) TTHETA !2-theta in centidegrees + REAL(kind=4) SIG,GAM + REAL(kind=4) SL,HL !S/L & H/L + REAL(kind=4) PRFUNC + REAL(kind=4) DPRDT + REAL(kind=4) SIGPART,GAMPART + REAL(kind=4) SLPART,HLPART !INCLUDE STATEMENTS: - REAL*4 SIND,COSD,TAND,ACOSD + REAL(kind=4) SIND,COSD,TAND,ACOSD !LOCAL VARIABLES: - REAL*4 R ! pseudo-voight intensity - REAL*4 DRDT ! deriv R w/r theta - REAL*4 DRDS ! deriv R w/r sig - REAL*4 DRDG ! deriv R w/r gam - REAL*4 F - REAL*4 G - REAL*4 DFDA - REAL*4 DGDA - REAL*4 DGDB - REAL*4 DYDA - REAL*4 DYDB - REAL*4 SIN2THETA2 ! sin(2theta)**2 - REAL*4 COS2THETA ! cos(2theta) - REAL*4 SIN2THETA ! sin(2THETA) - REAL*4 SINDELTA ! sin(Delta) - REAL*4 COSDELTA ! cos(Delta) - REAL*4 RCOSDELTA ! 1/cos(Delta) - REAL*4 TANDELTA ! tan(Delta) - REAL*4 COSDELTA2 ! cos(Delta)**2 - REAL*4 A ! asym1 [coff(7)] - REAL*4 B ! asym2 [coff(8)] - REAL*4 APB ! (A+B) - REAL*4 AMB ! (A-B) - REAL*4 APB2 ! (A+B)**2 - REAL*4 TTHETAD ! Two Theta in degrees + REAL(kind=4) R ! pseudo-voight intensity + REAL(kind=4) DRDT ! deriv R w/r theta + REAL(kind=4) DRDS ! deriv R w/r sig + REAL(kind=4) DRDG ! deriv R w/r gam + REAL(kind=4) F + REAL(kind=4) G + REAL(kind=4) DFDA + REAL(kind=4) DGDA + REAL(kind=4) DGDB + REAL(kind=4) DYDA + REAL(kind=4) DYDB + REAL(kind=4) SIN2THETA2 ! sin(2theta)**2 + REAL(kind=4) COS2THETA ! cos(2theta) + REAL(kind=4) SIN2THETA ! sin(2THETA) + REAL(kind=4) SINDELTA ! sin(Delta) + REAL(kind=4) COSDELTA ! cos(Delta) + REAL(kind=4) RCOSDELTA ! 1/cos(Delta) + REAL(kind=4) TANDELTA ! tan(Delta) + REAL(kind=4) COSDELTA2 ! cos(Delta)**2 + REAL(kind=4) A ! asym1 [coff(7)] + REAL(kind=4) B ! asym2 [coff(8)] + REAL(kind=4) APB ! (A+B) + REAL(kind=4) AMB ! (A-B) + REAL(kind=4) APB2 ! (A+B)**2 + REAL(kind=4) TTHETAD ! Two Theta in degrees ! Intermediate variables - REAL*4 RSUMWG2 ! 1.0/(sum of w G)**2 - REAL*4 SUMWG ! sum of w G - REAL*4 WG ! w G - REAL*4 RSUMWG ! 1.0/sum of w G - REAL*4 SUMWRG ! sum of w G - REAL*4 SUMWDGDA ! sum of w dGdA - REAL*4 SUMWRDGDA ! sum of w R dGdA - REAL*4 SUMWDGDB ! sum of w dGdB - REAL*4 SUMWRDGDB ! sum of w R dGdB - REAL*4 SUMWGDRD2T ! sum of w G dRd(2theta) - REAL*4 SUMWGDRDSIG ! sum of w G dRdp(n) - REAL*4 SUMWGDRDGAM ! sum of w G dRdp(n) - REAL*4 SUMWGDRDA - REAL*4 SUMWGDRDB - REAL*4 EMIN ! 2phi minimum - REAL*4 EINFL ! 2phi of inflection point - REAL*4 DEMINDA ! Derivative of Emin wrt A - REAL*4 DELTA ! Angle of integration for convolution - REAL*4 DDELTADA - REAL*4 TMP,TMP1,TMP2 ! intermediates - INTEGER*4 I,K,IT ! Miscellaneous loop variables + REAL(kind=4) RSUMWG2 ! 1.0/(sum of w G)**2 + REAL(kind=4) SUMWG ! sum of w G + REAL(kind=4) WG ! w G + REAL(kind=4) RSUMWG ! 1.0/sum of w G + REAL(kind=4) SUMWRG ! sum of w G + REAL(kind=4) SUMWDGDA ! sum of w dGdA + REAL(kind=4) SUMWRDGDA ! sum of w R dGdA + REAL(kind=4) SUMWDGDB ! sum of w dGdB + REAL(kind=4) SUMWRDGDB ! sum of w R dGdB + REAL(kind=4) SUMWGDRD2T ! sum of w G dRd(2theta) + REAL(kind=4) SUMWGDRDSIG ! sum of w G dRdp(n) + REAL(kind=4) SUMWGDRDGAM ! sum of w G dRdp(n) + REAL(kind=4) SUMWGDRDA + REAL(kind=4) SUMWGDRDB + REAL(kind=4) EMIN ! 2phi minimum + REAL(kind=4) EINFL ! 2phi of inflection point + REAL(kind=4) DEMINDA ! Derivative of Emin wrt A + REAL(kind=4) DELTA ! Angle of integration for convolution + REAL(kind=4) DDELTADA + REAL(kind=4) TMP,TMP1,TMP2 ! intermediates + INTEGER(kind=4) I,K,IT ! Miscellaneous loop variables c c Local Variables for Gaussian Integration c - INTEGER*4 NGT !NUMBER OF TERMS IN GAUSSIAN QUADRATURE - INTEGER*4 NUMTAB ! NUMBER OF PRE-COMPUTED GAUSSIAN TABLES + INTEGER(kind=4) NGT !NUMBER OF TERMS IN GAUSSIAN QUADRATURE + INTEGER(kind=4) NUMTAB ! NUMBER OF PRE-COMPUTED GAUSSIAN TABLES PARAMETER (NUMTAB=34) - INTEGER*4 NTERMS(NUMTAB) ! NUMBER OF TERMS IN EACH TABLE - MUST BE EVEN - INTEGER*4 FSTTERM(NUMTAB) ! LOCATION OF 1ST TERM: N.B. N/2 TERMS + INTEGER(kind=4) NTERMS(NUMTAB) ! NUMBER OF TERMS IN EACH TABLE - MUST BE EVEN + INTEGER(kind=4) FSTTERM(NUMTAB) ! LOCATION OF 1ST TERM: N.B. N/2 TERMS LOGICAL*4 CALCLFG(NUMTAB) ! TRUE IF TABLE HAS PREVIOUSLY BEEN CALCULATED - INTEGER*4 ARRAYNUM ! NUMBER OF SELECTED ARRAY - INTEGER*4 ARRAYSIZE ! SIZE OF COMPLETE ARRAY + INTEGER(kind=4) ARRAYNUM ! NUMBER OF SELECTED ARRAY + INTEGER(kind=4) ARRAYSIZE ! SIZE OF COMPLETE ARRAY PARAMETER (ARRAYSIZE=1670) - REAL*4 XP(ARRAYSIZE) !GAUSSIAN ABSCISSAS - REAL*4 WP(ARRAYSIZE) !GAUSSIAN WEIGHTS - REAL*4 XPT(400) !TEMPORARY GAUSSIAN ABSCISSAS - REAL*4 WPT(400) !TEMPORARY GAUSSIAN WEIGHTS - REAL*4 STOFW + REAL(kind=4) XP(ARRAYSIZE) !GAUSSIAN ABSCISSAS + REAL(kind=4) WP(ARRAYSIZE) !GAUSSIAN WEIGHTS + REAL(kind=4) XPT(400) !TEMPORARY GAUSSIAN ABSCISSAS + REAL(kind=4) WPT(400) !TEMPORARY GAUSSIAN WEIGHTS + REAL(kind=4) STOFW PARAMETER (STOFW=2.35482005) - REAL*4 TODEG + REAL(kind=4) TODEG PARAMETER (TODEG=57.2957795) SAVE CALCLFG,XP,WP !VALUES TO BE SAVED ACROSS CALLS diff --git a/sources/powsubs/psvoigt.for b/sources/powsubs/psvoigt.for index 551324ed6..d0fa7c973 100644 --- a/sources/powsubs/psvoigt.for +++ b/sources/powsubs/psvoigt.for @@ -9,26 +9,26 @@ !CALLING ARGUMENTS: - REAL*4 DX !Delta-x from center - REAL*4 SIG !Gaussian variance - REAL*4 GAM !Lorentzian FWHM - REAL*4 FUNC !Value of pseudo-Voigt at DX - REAL*4 DFDX !dF/dx - REAL*4 DFDS !dF/ds - REAL*4 DFDG !dF/dg + REAL(kind=4) DX !Delta-x from center + REAL(kind=4) SIG !Gaussian variance + REAL(kind=4) GAM !Lorentzian FWHM + REAL(kind=4) FUNC !Value of pseudo-Voigt at DX + REAL(kind=4) DFDX !dF/dx + REAL(kind=4) DFDS !dF/ds + REAL(kind=4) DFDG !dF/dg !INCLUDE STATEMENTS: !LOCAL VARIABLES: - REAL*4 COFG(6),COFL(6) !Linear combination coeffs - REAL*4 ACOFG(7),ACOFL(7) - REAL*4 GNORM !Gaussian Normalization constant - REAL*4 COFT(6),COFN(3) - REAL*4 EPS !Are values different + REAL(kind=4) COFG(6),COFL(6) !Linear combination coeffs + REAL(kind=4) ACOFG(7),ACOFL(7) + REAL(kind=4) GNORM !Gaussian Normalization constant + REAL(kind=4) COFT(6),COFN(3) + REAL(kind=4) EPS !Are values different ! Local variables saved between calls - REAL*4 PREV_SIG,PREV_GAM - REAL*4 ETA,FWHM,FRAC,DSDG,DSDL,SUMHM,DEDF,SQSG + REAL(kind=4) PREV_SIG,PREV_GAM + REAL(kind=4) ETA,FWHM,FRAC,DSDG,DSDL,SUMHM,DEDF,SQSG SAVE ETA,FWHM,FRAC,PREV_SIG,PREV_GAM,DSDG,DSDL,SUMHM, 1 DEDF,SQSG @@ -110,20 +110,20 @@ !CALLING ARGUMENTS: - REAL*4 DX !DELTA-X FROM CENTER - REAL*4 SIG !GAUSSIAN VARIANCE - REAL*4 GAM !LORENTZIAN FWHM - REAL*4 FUNC !VALUE OF PSEUDO-VOIGT AT DX - REAL*4 DFDX !DF/DX - REAL*4 DFDS !DF/DS - REAL*4 DFDG !DF/DG + REAL(kind=4) DX !DELTA-X FROM CENTER + REAL(kind=4) SIG !GAUSSIAN VARIANCE + REAL(kind=4) GAM !LORENTZIAN FWHM + REAL(kind=4) FUNC !VALUE OF PSEUDO-VOIGT AT DX + REAL(kind=4) DFDX !DF/DX + REAL(kind=4) DFDS !DF/DS + REAL(kind=4) DFDG !DF/DG !INCLUDE STATEMENTS: !LOCAL VARIABLES: - REAL*4 GNORM !GAUSSIAN NORMALIZATION CONSTANT - REAL*4 COFEG(7),COFEL(7),COFGG(6),COFGL(6) + REAL(kind=4) GNORM !GAUSSIAN NORMALIZATION CONSTANT + REAL(kind=4) COFEG(7),COFEL(7),COFGG(6),COFGL(6) !SUBROUTINES CALLED: diff --git a/sources/powsubs/sind.for b/sources/powsubs/sind.for index c0e35438d..864c2708e 100644 --- a/sources/powsubs/sind.for +++ b/sources/powsubs/sind.for @@ -1,4 +1,4 @@ - REAL*4 FUNCTION SIND(ARG) + REAL(kind=4) FUNCTION SIND(ARG) !PURPOSE: Calculate sine from angle in deg. @@ -6,7 +6,7 @@ !CALLING ARGUMENTS: - REAL*4 ARG !Sine argument in degrees + REAL(kind=4) ARG !Sine argument in degrees !INCLUDE STATEMENTS: diff --git a/sources/powsubs/tand.for b/sources/powsubs/tand.for index de506154e..9291881b4 100644 --- a/sources/powsubs/tand.for +++ b/sources/powsubs/tand.for @@ -1,4 +1,4 @@ - REAL*4 FUNCTION TAND(ARG) + REAL(kind=4) FUNCTION TAND(ARG) !PURPOSE: Calculate tangent from angle in deg. @@ -6,7 +6,7 @@ !CALLING ARGUMENTS: - REAL*4 ARG !Tangent argument in degrees + REAL(kind=4) ARG !Tangent argument in degrees !INCLUDE STATEMENTS: diff --git a/sources/pydiffax.for b/sources/pydiffax.for index 6865e9472..93c013325 100644 --- a/sources/pydiffax.for +++ b/sources/pydiffax.for @@ -9,9 +9,9 @@ cf2py intent(in) DEBG INCLUDE 'DIFFaXsubs/DIFFaX.par' INCLUDE 'DIFFaXsubs/DIFFaX.inc' - INTEGER*4 NATP,I,J + INTEGER(kind=4) NATP,I,J CHARACTER*4 ATYPES(NATP) - REAL*4 SFDAT(9,NATP) + REAL(kind=4) SFDAT(9,NATP) LOGICAL DEBG C fill common x-ray scattering factors @@ -38,7 +38,7 @@ Cf2py intent(in) DELTTH INCLUDE 'DIFFaXsubs/DIFFaX.par' INCLUDE 'DIFFaXsubs/DIFFaX.inc' - REAL*8 LAMB,TTHMIN,TTHMAX,DELTTH + REAL(kind=8) LAMB,TTHMIN,TTHMAX,DELTTH lambda = lamb th2_min = TTHMIN*DEG2RAD @@ -61,8 +61,8 @@ cf2py depend(NST) STSEQ INCLUDE 'DIFFaXsubs/DIFFaX.inc' CHARACTER*12 LAUESYM - INTEGER*4 CNTRLS(7),NST,STSEQ(NST),I - REAL*8 WDTH(2) + INTEGER(kind=4) CNTRLS(7),NST,STSEQ(NST),I + REAL(kind=8) WDTH(2) LOGICAL*4 ok,GETLAY EXTERNAL GETLAY @@ -133,10 +133,10 @@ Cf2py depend(NL) LNUM INCLUDE 'DIFFaXsubs/DIFFaX.par' INCLUDE 'DIFFaXsubs/DIFFaX.inc' - INTEGER*4 NATM,NL,LNUM(NL),NU,LSYM(NU) + INTEGER(kind=4) NATM,NL,LNUM(NL),NU,LSYM(NU) CHARACTER*4 ATMTP(NATM) - REAL*8 CELL(4),ATMXOU(8,NATM) - INTEGER*4 I,J,K,IL,IA + REAL(kind=8) CELL(4),ATMXOU(8,NATM) + INTEGER(kind=4) I,J,K,IL,IA C fill Common - cell stuff & finish symmetry stuff cell_a = CELL(1) @@ -187,9 +187,9 @@ Cf2py depend(NL) TRP,TRX INCLUDE 'DIFFaXsubs/DIFFaX.par' INCLUDE 'DIFFaXsubs/DIFFaX.inc' - INTEGER*4 I,J,K - INTEGER*4 NL - REAL*4 TRP(NL,NL),TRX(NL,NL,3) + INTEGER(kind=4) I,J,K + INTEGER(kind=4) NL + REAL(kind=4) TRP(NL,NL),TRX(NL,NL,3) C fill common transitions stuff DO J=1,NL @@ -213,8 +213,8 @@ Cf2py depend(NSADP) SADP INCLUDE 'DIFFaXsubs/DIFFaX.par' INCLUDE 'DIFFaXsubs/DIFFaX.inc' - INTEGER*4 CNTRLS(7),NSADP,I,j,k - REAL*8 SADP(NSADP),AGLQ16 + INTEGER(kind=4) CNTRLS(7),NSADP,I,j,k + REAL(kind=8) SADP(NSADP),AGLQ16 LOGICAL GETSPC,ok EXTERNAL AGLQ16,GETSPC @@ -273,8 +273,8 @@ Cf2py depend(NBRD) BRDSPC INCLUDE 'DIFFaXsubs/DIFFaX.par' INCLUDE 'DIFFaXsubs/DIFFaX.inc' - INTEGER*4 BLUR,i,NBRD - REAL*8 U,V,W,HW,BRDSPC(NBRD),tth_min + INTEGER(kind=4) BLUR,i,NBRD + REAL(kind=8) U,V,W,HW,BRDSPC(NBRD),tth_min tth_min = ZERO @@ -308,9 +308,9 @@ Cf2py intent(out) NBLK INCLUDE 'DIFFaXsubs/DIFFaX.par' INCLUDE 'DIFFaXsubs/DIFFaX.inc' - INTEGER*4 CNTRLS(7),NSADP,i_plane,hk_lim,i,j,k - INTEGER*4 HKLIM,NBLK - REAL*8 SADP(NSADP),AGLQ16,l_upper,INCR + INTEGER(kind=4) CNTRLS(7),NSADP,i_plane,hk_lim,i,j,k + INTEGER(kind=4) HKLIM,NBLK + REAL(kind=8) SADP(NSADP),AGLQ16,l_upper,INCR LOGICAL ok EXTERNAL AGLQ16 diff --git a/sources/pypowder.for b/sources/pypowder.for index 68dc8799e..e69438f62 100644 --- a/sources/pypowder.for +++ b/sources/pypowder.for @@ -14,10 +14,10 @@ Cf2py intent(in) CDGAM Cf2py intent(in) SPH Cf2py intent(out) PRFUNC Cf2py depend(NPTS) PRFUNC - REAL*4 DTT(0:NPTS-1),PRFUNC(0:NPTS-1) - REAL*4 TTHETA,SIG,CDSIG,CDGAM,SPH,DPRDT,DPRDG,DPRDD,DPRDLZ,DPRDS - REAL*4 GAM - INTEGER*4 NPTS,I + REAL(kind=4) DTT(0:NPTS-1),PRFUNC(0:NPTS-1) + REAL(kind=4) TTHETA,SIG,CDSIG,CDGAM,SPH,DPRDT,DPRDG,DPRDD,DPRDLZ,DPRDS + REAL(kind=4) GAM + INTEGER(kind=4) NPTS,I C CDSIG is in centidegrees squared, we must change to normal degrees SIG = CDSIG/10000.0 GAM = CDGAM/100.0 @@ -52,11 +52,11 @@ Cf2py intent(out) GAMPART Cf2py depend(NPTS) GAMPART Cf2py intent(out) SLPART Cf2py depend(NPTS) SLPART - INTEGER*4 NPTS,I - REAL*4 TTHETA,CDSIG,SIG,CDGAM,SPH,LPART - REAL*4 GAM - REAL*4 DTT(0:NPTS-1),DPRDT(0:NPTS-1),SIGPART(0:NPTS-1) - REAL*4 GAMPART(0:NPTS-1),SLPART(0:NPTS-1),PRFUNC(0:NPTS-1) + INTEGER(kind=4) NPTS,I + REAL(kind=4) TTHETA,CDSIG,SIG,CDGAM,SPH,LPART + REAL(kind=4) GAM + REAL(kind=4) DTT(0:NPTS-1),DPRDT(0:NPTS-1),SIGPART(0:NPTS-1) + REAL(kind=4) GAMPART(0:NPTS-1),SLPART(0:NPTS-1),PRFUNC(0:NPTS-1) SIG = CDSIG/10000. GAM = CDGAM/100. DO I=0,NPTS-1 @@ -83,9 +83,9 @@ Cf2py intent(in) GAM Cf2py intent(out) PRFUNC Cf2py depend(NPTS) PRFUNC - REAL*4 DTT(0:NPTS-1),PRFUNC(0:NPTS-1) - REAL*4 SIG,GAM - INTEGER*4 NPTS,I + REAL(kind=4) DTT(0:NPTS-1),PRFUNC(0:NPTS-1) + REAL(kind=4) SIG,GAM + INTEGER(kind=4) NPTS,I DO I=0,NPTS-1 CALL PSVOIGT(DTT(I)*100.,SIG,GAM, 1 PRFUNC(I),DPRDT,SIGPART,GAMPART) @@ -111,9 +111,9 @@ Cf2py depend(NPTS) SIGPART Cf2py intent(out) GAMPART Cf2py depend(NPTS) GAMPART - INTEGER*4 NPTS - REAL*4 SIG,GAM - REAL*4 DTT(0:NPTS-1),DPRDT(0:NPTS-1),SIGPART(0:NPTS-1), + INTEGER(kind=4) NPTS + REAL(kind=4) SIG,GAM + REAL(kind=4) DTT(0:NPTS-1),DPRDT(0:NPTS-1),SIGPART(0:NPTS-1), 1 GAMPART(0:NPTS-1),PRFUNC(0:NPTS-1) DO I=0,NPTS-1 CALL PSVOIGT(DTT(I)*100.,SIG,GAM, @@ -138,9 +138,9 @@ Cf2py intent(in) SPH Cf2py intent(out) PRFUNC Cf2py depend(NPTS) PRFUNC - INTEGER*4 NPTS - REAL*4 TTHETA,SIG,GAM,SPH - REAL*4 DTT(0:NPTS-1),PRFUNC(0:NPTS-1) + INTEGER(kind=4) NPTS + REAL(kind=4) TTHETA,SIG,GAM,SPH + REAL(kind=4) DTT(0:NPTS-1),PRFUNC(0:NPTS-1) DO I=0,NPTS-1 CALL PSVFCJO(DTT(I)*100.,TTHETA*100.,SIG,GAM,SPH/2.0,SPH/2.0, 1 PRFUNC(I),DPRDT,SIGPART,GAMPART,SLPART,HLPART) @@ -172,9 +172,9 @@ Cf2py depend(NPTS) GAMPART Cf2py intent(out) SLPART Cf2py depend(NPTS) SLPART - INTEGER*4 NPTS - REAL*4 TTHETA,SIG,GAM,SPH - REAL*4 DTT(0:NPTS-1),DPRDT(0:NPTS-1),SIGPART(0:NPTS-1), + INTEGER(kind=4) NPTS + REAL(kind=4) TTHETA,SIG,GAM,SPH + REAL(kind=4) DTT(0:NPTS-1),DPRDT(0:NPTS-1),SIGPART(0:NPTS-1), 1 GAMPART(0:NPTS-1),SLPART(0:NPTS-1),PRFUNC(0:NPTS-1) DO I=0,NPTS-1 CALL PSVFCJO(DTT(I)*100.,TTHETA*100.,SIG,GAM,SPH/2.,SPH/2., @@ -203,9 +203,9 @@ Cf2py intent(in) SPH Cf2py intent(out) PRFUNC Cf2py depend(NPTS) PRFUNC - INTEGER*4 NPTS - REAL*4 TTHETA,ALP,BET,SIG,GAM,SPH,PFUNC - REAL*4 DTT(0:NPTS-1),PRFUNC(0:NPTS-1),DPRDT,ALPART,BEPART,SIGPART + INTEGER(kind=4) NPTS + REAL(kind=4) TTHETA,ALP,BET,SIG,GAM,SPH,PFUNC + REAL(kind=4) DTT(0:NPTS-1),PRFUNC(0:NPTS-1),DPRDT,ALPART,BEPART,SIGPART 1 GAMPART,SLPART,HLPART DO I=0,NPTS-1 CALL PSVFCJEXPO(DTT(I),TTHETA,ALP,BET,SIG/1.e4,GAM/100.,SPH/2.0, @@ -246,9 +246,9 @@ Cf2py depend(NPTS) GAMPART Cf2py intent(out) SLPART Cf2py depend(NPTS) SLPART - INTEGER*4 NPTS - REAL*4 TTHETA,ALP,BET,SIG,GAM,SHL,HPART,SGPART,GAPART,PFUNC - REAL*4 DTT(0:NPTS-1),DPRDT(0:NPTS-1),ALPART(0:NPTS-1), + INTEGER(kind=4) NPTS + REAL(kind=4) TTHETA,ALP,BET,SIG,GAM,SHL,HPART,SGPART,GAPART,PFUNC + REAL(kind=4) DTT(0:NPTS-1),DPRDT(0:NPTS-1),ALPART(0:NPTS-1), 1 BEPART(0:NPTS-1),SIGPART(0:NPTS-1),GAMPART(0:NPTS-1), 1 SLPART(0:NPTS-1),PRFUNC(0:NPTS-1),APART,BPART,DPDT DO I=0,NPTS-1 @@ -279,9 +279,9 @@ Cf2py intent(in) GAM Cf2py intent(out) PRFUNC Cf2py depend(NPTS) PRFUNC - INTEGER*4 NPTS - REAL*4 ALP,BET,SIG,GAM,SHL - REAL*4 DTT(0:NPTS-1),PRFUNC(0:NPTS-1),DPRDT,ALPPART, + INTEGER(kind=4) NPTS + REAL(kind=4) ALP,BET,SIG,GAM,SHL + REAL(kind=4) DTT(0:NPTS-1),PRFUNC(0:NPTS-1),DPRDT,ALPPART, 1 BETPART,SIGPART,GAMPART DO I=0,NPTS-1 CALL EPSVOIGT(DTT(I),ALP,BET,SIG,GAM,PRFUNC(I),DPRDT, @@ -314,9 +314,9 @@ Cf2py depend(NPTS) SIGPART Cf2py intent(out) GAMPART Cf2py depend(NPTS) GAMPART - INTEGER*4 NPTS - REAL*4 ALP,BET,SIG,GAM,SHL - REAL*4 DTT(0:NPTS-1),DPRDT(0:NPTS-1),ALPPART(0:NPTS-1), + INTEGER(kind=4) NPTS + REAL(kind=4) ALP,BET,SIG,GAM,SHL + REAL(kind=4) DTT(0:NPTS-1),DPRDT(0:NPTS-1),ALPPART(0:NPTS-1), 1 BETPART(0:NPTS-1),SIGPART(0:NPTS-1), 1 GAMPART(0:NPTS-1),PRFUNC(0:NPTS-1) DO I=0,NPTS-1 @@ -336,8 +336,8 @@ Cf2py depend(N) GL Cf2py intent(out) WT Cf2py depends(N) WT - INTEGER*4 N - REAL*4 X1,X2,GL(0:N-1),WT(0:N-1) + INTEGER(kind=4) N + REAL(kind=4) X1,X2,GL(0:N-1),WT(0:N-1) CALL GAULEG(X1,X2,GL,WT,N) RETURN END diff --git a/sources/pyspg.for b/sources/pyspg.for index 6d24cebde..267e986be 100644 --- a/sources/pyspg.for +++ b/sources/pyspg.for @@ -15,10 +15,10 @@ Cf2py intent(out) SGGEN Cf2py intent(out) IERR CHARACTER*(20) SPG - INTEGER*4 LAUE,SGINV,SGLATT,SGUNIQ,SGNOPS,IERR,SGNCEN - REAL*4 SGMTRX(24,3,3),SGTRNS(24,3),SGGEN(24) - REAL*4 RT(5,4,25),CEN(3,4) - INTEGER*4 JRT(3,5,24) + INTEGER(kind=4) LAUE,SGINV,SGLATT,SGUNIQ,SGNOPS,IERR,SGNCEN + REAL(kind=4) SGMTRX(24,3,3),SGTRNS(24,3),SGGEN(24) + REAL(kind=4) RT(5,4,25),CEN(3,4) + INTEGER(kind=4) JRT(3,5,24) CALL SGROUPNP(SPG,LAUE,SGUNIQ,SGINV,SGLATT,SGNOPS,SGPOL,JRT, @@ -51,10 +51,10 @@ Cf2py intent(out) HKL Cf2py intent(out) IABSNT Cf2py intent(out) MULP - INTEGER*4 ICEN,NSYM - REAL*4 SGMTRX(NSYM,3,3),SGTRNS(NSYM,3),SGCEN(NCV,3) - REAL*4 CEN(3,NCV),HKL(4,24),XH(4) - INTEGER*4 JRT(3,5,24),JHK,NCV + INTEGER(kind=4) ICEN,NSYM + REAL(kind=4) SGMTRX(NSYM,3,3),SGTRNS(NSYM,3),SGCEN(NCV,3) + REAL(kind=4) CEN(3,NCV),HKL(4,24),XH(4) + INTEGER(kind=4) JRT(3,5,24),JHK,NCV DO J=1,NCV DO I=1,3 diff --git a/sources/pytexture.for b/sources/pytexture.for index 01d8ea331..91ac90d9b 100644 --- a/sources/pytexture.for +++ b/sources/pytexture.for @@ -7,11 +7,11 @@ Cf2py intent(out) PCRS Cf2py intent(out) DPDPS Cf2py depend(NPHI) PHI,PCRS,DPDPS - INTEGER*4 L - INTEGER*4 I - REAL*4 PHI(0:NPHI-1) - REAL*4 PCRS(0:NPHI-1) - REAL*4 DPDPS(0:NPHI-1) + INTEGER(kind=4) L + INTEGER(kind=4) I + REAL(kind=4) PHI(0:NPHI-1) + REAL(kind=4) PCRS(0:NPHI-1) + REAL(kind=4) DPDPS(0:NPHI-1) DO K = 0,NPHI-1 CALL PLMPSI(L,I,PHI(K),PCRS(K),DPDPS(K)) diff --git a/sources/spotmask.for b/sources/spotmask.for index fda61dd42..328e194ed 100644 --- a/sources/spotmask.for +++ b/sources/spotmask.for @@ -11,13 +11,13 @@ Cf2py depend(M) SPOTS Cf2py intent(in,out) MASK IMPLICIT NONE - INTEGER*4 N,M - REAL*4 X(0:N-1),Y(0:N-1) - REAL*8 SPOTS(0:M-1,0:2) + INTEGER(kind=4) N,M + REAL(kind=4) X(0:N-1),Y(0:N-1) + REAL(kind=8) SPOTS(0:M-1,0:2) LOGICAL*1 MASK(0:1024*1024-1) - INTEGER*4 I,K - REAL*4 XYRAD2,XINTERS + INTEGER(kind=4) I,K + REAL(kind=4) XYRAD2,XINTERS DO K=0,N-1 MASK(K) = .FALSE. diff --git a/sources/spsubs/genhkl.for b/sources/spsubs/genhkl.for index 904936acc..6d437a9de 100644 --- a/sources/spsubs/genhkl.for +++ b/sources/spsubs/genhkl.for @@ -6,20 +6,20 @@ ! Input data list - REAL*4 XH(4) ! Input Miller indices - INTEGER*4 NSYM ! Number of symmetry matrices - INTEGER*4 RT(3,5,24) ! The symmetry matrices - INTEGER*4 ICEN ! Flag indicating 1bar - INTEGER*4 NCV ! The number of lattice centering vectors - REAL*4 CEN(3,NCV) ! The lattice centering vectors + REAL(kind=4) XH(4) ! Input Miller indices + INTEGER(kind=4) NSYM ! Number of symmetry matrices + INTEGER(kind=4) RT(3,5,24) ! The symmetry matrices + INTEGER(kind=4) ICEN ! Flag indicating 1bar + INTEGER(kind=4) NCV ! The number of lattice centering vectors + REAL(kind=4) CEN(3,NCV) ! The lattice centering vectors !Output data list - INTEGER*4 JHK ! Number of equivalent indices generated - REAL*4 HKL(4,24) ! The generated Miller indices - INTEGER*4 IHKL(4,24) ! The generated Miller indices - INTEGER*4 IABSNT ! Space group absence flag - INTEGER*4 MULP ! Multiplicity for powder line intensities + INTEGER(kind=4) JHK ! Number of equivalent indices generated + REAL(kind=4) HKL(4,24) ! The generated Miller indices + INTEGER(kind=4) IHKL(4,24) ! The generated Miller indices + INTEGER(kind=4) IABSNT ! Space group absence flag + INTEGER(kind=4) MULP ! Multiplicity for powder line intensities !CODE diff --git a/sources/spsubs/sglatc.for b/sources/spsubs/sglatc.for index cf97d82ba..0075fac04 100644 --- a/sources/spsubs/sglatc.for +++ b/sources/spsubs/sglatc.for @@ -13,15 +13,15 @@ !Calling sequence variables - INTEGER*4 K !Number of fields found in the space group symbol - INTEGER*4 L(4,4) !Integer values for the characters in the symbol - REAL*4 D(3,3) !Location of some key elements - INTEGER*4 LCENT !Lattice centering flag - INTEGER*4 LAUENO !Laue Group number - INTEGER*4 NAXIS !Unique axis flag for monoclinic cells - INTEGER*4 IER !Error flag - INTEGER*4 I209 !Diagonal 3-axis flag - INTEGER*4 ID !Number of D-glides + INTEGER(kind=4) K !Number of fields found in the space group symbol + INTEGER(kind=4) L(4,4) !Integer values for the characters in the symbol + REAL(kind=4) D(3,3) !Location of some key elements + INTEGER(kind=4) LCENT !Lattice centering flag + INTEGER(kind=4) LAUENO !Laue Group number + INTEGER(kind=4) NAXIS !Unique axis flag for monoclinic cells + INTEGER(kind=4) IER !Error flag + INTEGER(kind=4) I209 !Diagonal 3-axis flag + INTEGER(kind=4) ID !Number of D-glides !Local variables: diff --git a/sources/spsubs/sglcen.for b/sources/spsubs/sglcen.for index c0ffda344..c3757e66f 100644 --- a/sources/spsubs/sglcen.for +++ b/sources/spsubs/sglcen.for @@ -9,12 +9,12 @@ C The National Research Council of Canada C by C Allen C. Larson, 14 Cerrado Loop, Santa Fe, NM 87505, USA - INTEGER*4 LCENT !Lattice centering type flag - REAL*4 CEN(3,4) !List of lattice centering vectors - INTEGER*4 NCV !Number of lattcie centering vectors + INTEGER(kind=4) LCENT !Lattice centering type flag + REAL(kind=4) CEN(3,4) !List of lattice centering vectors + INTEGER(kind=4) NCV !Number of lattcie centering vectors - REAL*4 CENV(3,6) - INTEGER*4 NCVT(7) + REAL(kind=4) CENV(3,6) + INTEGER(kind=4) NCVT(7) DATA NCVT/1,2,2,2,2,4,3/ DATA CENV/ 0,0.5,0.5, 0.5,0,0.5, 0.5,0.5,0, 0.5,0.5,0.5, diff --git a/sources/spsubs/sgmtml.for b/sources/spsubs/sgmtml.for index 572d0ef61..f7a1f6578 100644 --- a/sources/spsubs/sgmtml.for +++ b/sources/spsubs/sgmtml.for @@ -11,10 +11,10 @@ C The National Research Council of Canada C by C Allen C. Larson, 14 Cerrado Loop, Santa Fe, NM 87505, USA - REAL*4 X(5,4,25) - INTEGER*4 I !Input matrix number - INTEGER*4 J !Input matrix number - INTEGER*4 K !Output matrix number + REAL(kind=4) X(5,4,25) + INTEGER(kind=4) I !Input matrix number + INTEGER(kind=4) J !Input matrix number + INTEGER(kind=4) K !Output matrix number DO L=1,4 DO M=1,4 diff --git a/sources/spsubs/sgoprn.for b/sources/spsubs/sgoprn.for index 4aa80f071..4847127b9 100644 --- a/sources/spsubs/sgoprn.for +++ b/sources/spsubs/sgoprn.for @@ -7,13 +7,13 @@ !CALL SEQUENCE PARAMETERS: - REAL*4 MVAL !Packed matrix value + REAL(kind=4) MVAL !Packed matrix value !Local variables: LOGICAL*4 NOTFOUND !Loop control flag - REAL*4 MATVALS(64) !Packed matrix values - REAL*4 OPRFLGS(64) !Operation flags + REAL(kind=4) MATVALS(64) !Packed matrix values + REAL(kind=4) OPRFLGS(64) !Operation flags !Data statements: diff --git a/sources/spsubs/sgrmat.for b/sources/spsubs/sgrmat.for index 32d27b0c9..21c16d0bb 100644 --- a/sources/spsubs/sgrmat.for +++ b/sources/spsubs/sgrmat.for @@ -13,10 +13,10 @@ C ALLEN C. LARSON, 14 CERRADO LOOP, SANTA FE, NM 87505, USA !Calling sequence parameters: - INTEGER*4 IOP !Matrix generator count - REAL*4 RT(5,4,25) !Matrix to be generated - INTEGER*4 N !Number of the matrix to be generated - REAL*4 A,B,C,D,E,F,G,H,O !Matrix terms + INTEGER(kind=4) IOP !Matrix generator count + REAL(kind=4) RT(5,4,25) !Matrix to be generated + INTEGER(kind=4) N !Number of the matrix to be generated + REAL(kind=4) A,B,C,D,E,F,G,H,O !Matrix terms !Local varaibles: diff --git a/sources/spsubs/sgroupnp.for b/sources/spsubs/sgroupnp.for index cba48c9f7..80c7abafc 100644 --- a/sources/spsubs/sgroupnp.for +++ b/sources/spsubs/sgroupnp.for @@ -33,14 +33,14 @@ ! RT Scratch array of 500 words needed by sgroup ! IER Error flag no. - INTEGER*4 JRT(3,5,24) !Output matrices, with flags + INTEGER(kind=4) JRT(3,5,24) !Output matrices, with flags CHARACTER*20 SPG !Input stribg to be parced - REAL*4 CEN(3,4) !Lattice centering vectors - REAL*4 RT(5,4,25) !Raw trial matrices with some flags - REAL*4 D(3,3) !Origin definition data + REAL(kind=4) CEN(3,4) !Lattice centering vectors + REAL(kind=4) RT(5,4,25) !Raw trial matrices with some flags + REAL(kind=4) D(3,3) !Origin definition data CHARACTER*33 CHR !List of characters which will be recognized - INTEGER*4 LCEN(7) !Latice centering flags - INTEGER*4 L(4,4) !First parcing output, Characters converted to numbers + INTEGER(kind=4) LCEN(7) !Latice centering flags + INTEGER(kind=4) L(4,4) !First parcing output, Characters converted to numbers ! C B A P F I R DATA LCEN/4,3,2,1,6,5,7/ diff --git a/sources/spsubs/sgtrcf.for b/sources/spsubs/sgtrcf.for index 2f364210e..f6fe24240 100644 --- a/sources/spsubs/sgtrcf.for +++ b/sources/spsubs/sgtrcf.for @@ -11,13 +11,13 @@ C The National Research Council of Canada C by C Allen C. Larson, 14 Cerrado Loop, Santa Fe, NM 87505-8832, USA - INTEGER*4 M ! - REAL*4 RT(5,4,25) !Matrices being generated - INTEGER*4 N !Sequence no. of matrix 1 - INTEGER*4 M2 !Sequence no. of matrix 2 - INTEGER*4 LCENT !Number of Lattice centering vectors - INTEGER*4 LAUENO !Laue group flag - INTEGER*4 IER !Error flag + INTEGER(kind=4) M ! + REAL(kind=4) RT(5,4,25) !Matrices being generated + INTEGER(kind=4) N !Sequence no. of matrix 1 + INTEGER(kind=4) M2 !Sequence no. of matrix 2 + INTEGER(kind=4) LCENT !Number of Lattice centering vectors + INTEGER(kind=4) LAUENO !Laue group flag + INTEGER(kind=4) IER !Error flag DIMENSION ICENV(3,5),NCVT(7),JCVT(7) DATA ICENV/0,0,0, 0,6,6, 6,0,6, 6,6,0, 6,6,6/ diff --git a/sources/texturesubs/aplms.for b/sources/texturesubs/aplms.for index 055e39c9e..cf99f1789 100644 --- a/sources/texturesubs/aplms.for +++ b/sources/texturesubs/aplms.for @@ -6,14 +6,14 @@ !CALLING ARGUMENTS: - INTEGER*4 L,M,S !Order & subindices - REAL*4 AP !Output value + INTEGER(kind=4) L,M,S !Order & subindices + REAL(kind=4) AP !Output value !INCLUDE STATEMENTS: !LOCAL VARIABLES: - REAL*4 LNORM,ALM0S,A1,A2 + REAL(kind=4) LNORM,ALM0S,A1,A2 !FUNCTION DEFINITIONS: diff --git a/sources/texturesubs/cosd.for b/sources/texturesubs/cosd.for index 44df78abd..eb3de0bb1 100644 --- a/sources/texturesubs/cosd.for +++ b/sources/texturesubs/cosd.for @@ -1,4 +1,4 @@ - REAL*4 FUNCTION COSD(ARG) + REAL(kind=4) FUNCTION COSD(ARG) !PURPOSE: Calculate cosine from angle in deg. @@ -6,7 +6,7 @@ !CALLING ARGUMENTS: - REAL*4 ARG !Cosine argument in degrees + REAL(kind=4) ARG !Cosine argument in degrees !INCLUDE STATEMENTS: diff --git a/sources/texturesubs/dgammln.for b/sources/texturesubs/dgammln.for index 01526247b..eb2dd4239 100644 --- a/sources/texturesubs/dgammln.for +++ b/sources/texturesubs/dgammln.for @@ -8,14 +8,14 @@ !CALLING ARGUMENTS: - REAL*8 DGAMMLN !ln(gamma(xx)) with xx>0 - REAL*4 XX !argument must be >0 + REAL(kind=8) DGAMMLN !ln(gamma(xx)) with xx>0 + REAL(kind=4) XX !argument must be >0 !INCLUDE STATEMENTS: !LOCAL VARIABLES: - REAL*8 COF(6),STP,HALF,ONE,FPF,X,TMP,SER + REAL(kind=8) COF(6),STP,HALF,ONE,FPF,X,TMP,SER !SUBROUTINES CALLED: diff --git a/sources/texturesubs/factln.for b/sources/texturesubs/factln.for index 0b21165f4..e3d0fa436 100644 --- a/sources/texturesubs/factln.for +++ b/sources/texturesubs/factln.for @@ -6,19 +6,19 @@ !CALLING ARGUMENTS: - INTEGER*4 N !Order of factorial - REAL*8 FACTLN !ln(N!) returned + INTEGER(kind=4) N !Order of factorial + REAL(kind=8) FACTLN !ln(N!) returned !INCLUDE STATEMENTS: !LOCAL VARIABLES: - REAL*8 A(100) - INTEGER*4 IA(100) + REAL(kind=8) A(100) + INTEGER(kind=4) IA(100) !FUNCTION DEFINITIONS: - REAL*8 DGAMMLN + REAL(kind=8) DGAMMLN !DATA STATEMENTS: diff --git a/sources/texturesubs/plmpsi.for b/sources/texturesubs/plmpsi.for index 37952b600..d0ad40dae 100644 --- a/sources/texturesubs/plmpsi.for +++ b/sources/texturesubs/plmpsi.for @@ -6,16 +6,16 @@ !CALLING ARGUMENTS: - INTEGER*4 L,M !Order & index - REAL*4 PSI !Angle (in deg) - REAL*4 P !Value returned + INTEGER(kind=4) L,M !Order & index + REAL(kind=4) PSI !Angle (in deg) + REAL(kind=4) P !Value returned !INCLUDE STATEMENTS: !LOCAL VARIABLES: - INTEGER*4 S - REAL*4 APR,RS + INTEGER(kind=4) S + REAL(kind=4) APR,RS !FUNCTION DEFINITIONS: diff --git a/sources/texturesubs/qlmn.for b/sources/texturesubs/qlmn.for index a4809e43f..54e15a130 100644 --- a/sources/texturesubs/qlmn.for +++ b/sources/texturesubs/qlmn.for @@ -6,23 +6,23 @@ !CALLING ARGUMENTS: - INTEGER*4 L,MM,NN !order & subindices (m may be <0) - REAL*4 Q !Output value + INTEGER(kind=4) L,MM,NN !order & subindices (m may be <0) + REAL(kind=4) Q !Output value !INCLUDE STATEMENTS: - REAL*4 QT + REAL(kind=4) QT COMMON /QLMNVAL/QT(2109) !LOCAL VARIABLES: - REAL*8 SUM,TEMP,TEMP1 - INTEGER*4 LMN,I,J,M,N + REAL(kind=8) SUM,TEMP,TEMP1 + INTEGER(kind=4) LMN,I,J,M,N !FUNCTION DEFINITIONS: - REAL*8 FACTLN !Compute ln-factorial & binominal coeffs. + REAL(kind=8) FACTLN !Compute ln-factorial & binominal coeffs. !DATA STATEMENTS: diff --git a/sources/texturesubs/qlmninit.for b/sources/texturesubs/qlmninit.for index d1eccfc7b..3b463743e 100644 --- a/sources/texturesubs/qlmninit.for +++ b/sources/texturesubs/qlmninit.for @@ -9,17 +9,17 @@ !INCLUDE STATEMENTS: - REAL*4 QT + REAL(kind=4) QT COMMON /QLMNVAL/QT(2109) !LOCAL VARIABLES: - REAL*8 SUM,TEMP,TEMP1 - INTEGER*4 I,LMN,M,MM + REAL(kind=8) SUM,TEMP,TEMP1 + INTEGER(kind=4) I,LMN,M,MM !FUNCTION DEFINITIONS: - REAL*8 FACTLN !Compute ln-factorial & binominal coeffs. + REAL(kind=8) FACTLN !Compute ln-factorial & binominal coeffs. !DATA STATEMENTS: diff --git a/sources/texturesubs/sind.for b/sources/texturesubs/sind.for index c0e35438d..864c2708e 100644 --- a/sources/texturesubs/sind.for +++ b/sources/texturesubs/sind.for @@ -1,4 +1,4 @@ - REAL*4 FUNCTION SIND(ARG) + REAL(kind=4) FUNCTION SIND(ARG) !PURPOSE: Calculate sine from angle in deg. @@ -6,7 +6,7 @@ !CALLING ARGUMENTS: - REAL*4 ARG !Sine argument in degrees + REAL(kind=4) ARG !Sine argument in degrees !INCLUDE STATEMENTS: diff --git a/sources/unpack_cbf.for b/sources/unpack_cbf.for index 0a4ca99d9..5fb332074 100644 --- a/sources/unpack_cbf.for +++ b/sources/unpack_cbf.for @@ -8,16 +8,16 @@ Cf2py intent(in,out) IMG Cf2py depend(MXY) IMG IMPLICIT NONE - INTEGER*4 N,MXY + INTEGER(kind=4) N,MXY CHARACTER*1 CMPR(0:N-1) - INTEGER*4 IMG(0:MXY-1),BASEPIXEL - INTEGER*4 I,J,ISIZE + INTEGER(kind=4) IMG(0:MXY-1),BASEPIXEL + INTEGER(kind=4) I,J,ISIZE CHARACTER*1 C1,E1 CHARACTER*2 C2,E2 CHARACTER*4 C4,E4 - INTEGER*1 IONEBYTE - INTEGER*2 ITWOBYTES - INTEGER*4 IFOURBYTES + INTEGER(kind=1) IONEBYTE + INTEGER(kind=2) ITWOBYTES + INTEGER(kind=4) IFOURBYTES E1 = CHAR(128) E2 = CHAR(0)//CHAR(128) @@ -77,16 +77,16 @@ Cf2py intent(in,out) IMG Cf2py depend(MXY) IMG IMPLICIT NONE - INTEGER*4 N,MXY - INTEGER*1 CMPR(0:N-1) - INTEGER*4 IMG(0:MXY-1),BASEPIXEL - INTEGER*4 I,J,ISIZE + INTEGER(kind=4) N,MXY + INTEGER(kind=1) CMPR(0:N-1) + INTEGER(kind=4) IMG(0:MXY-1),BASEPIXEL + INTEGER(kind=4) I,J,ISIZE CHARACTER*1 C1,E1 CHARACTER*2 C2,E2 CHARACTER*4 C4,E4 - INTEGER*1 IONEBYTE - INTEGER*2 ITWOBYTES - INTEGER*4 IFOURBYTES + INTEGER(kind=1) IONEBYTE + INTEGER(kind=2) ITWOBYTES + INTEGER(kind=4) IFOURBYTES E1 = CHAR(128) E2 = CHAR(0)//CHAR(128) From 870eeab70a1d37a5d74c0d2004d75eee14ae42e2 Mon Sep 17 00:00:00 2001 From: Thomas A Caswell Date: Fri, 14 Feb 2025 12:05:10 -0500 Subject: [PATCH 2/3] MNT: fortran 2018 dropped support for shared labeled continues --- sources/NISTlatsubs/QMATRI.f | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/sources/NISTlatsubs/QMATRI.f b/sources/NISTlatsubs/QMATRI.f index dfa079eb0..9b858e530 100644 --- a/sources/NISTlatsubs/QMATRI.f +++ b/sources/NISTlatsubs/QMATRI.f @@ -25,8 +25,8 @@ SUBROUTINE QMATRI C DO 300 IDEL = IDEL1,IDEL2 DO 200 I = 1,IDEL - DO 200 J = 1,IDEL - DO 200 K = 1,IDEL + DO J = 1,IDEL + DO K = 1,IDEL IPROD = I*J*K IF(IPROD.NE.IDEL) GO TO 200 C @@ -47,8 +47,8 @@ SUBROUTINE QMATRI C C --- GENERATE ALL MATRICES CONSISTENT WITH GIVEN DIAGONAL DO 100 II = 1,IDEL - DO 100 JJ = 1,IDEL - DO 100 KK = 1,IDEL + DO JJ = 1,IDEL + DO KK = 1,IDEL IQ12 = II - 1 IQ13 = JJ - 1 IQ23 = KK - 1 @@ -75,7 +75,11 @@ SUBROUTINE QMATRI ISQ22(IQMATF) = IQ22 ISQ23(IQMATF) = IQ23 ISQ33(IQMATF) = IQ33 + END DO + END DO 100 CONTINUE + END DO + END DO 200 CONTINUE 300 CONTINUE RETURN From b9bfdc8e4549c572bc4a8b022bf43d7e151b2289 Mon Sep 17 00:00:00 2001 From: Thomas A Caswell Date: Fri, 14 Feb 2025 12:09:20 -0500 Subject: [PATCH 3/3] BLD: move optimization options to project level --- meson.build | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/meson.build b/meson.build index f2088063f..c49234474 100644 --- a/meson.build +++ b/meson.build @@ -3,7 +3,12 @@ project( 'c', 'cython', 'fortran', version: '2.0.0', license: 'BSD', - meson_version: '>= 1.1.0', + meson_version: '>= 1.2.0', + default_options : { + 'optimization': '2', + # 'fortran_std': 'f2018' + } + ) # Seek the backend @@ -26,10 +31,11 @@ if fc.get_id() == 'gcc' # add_global_arguments('-fcheck=bounds', language : 'fortran') add_global_arguments('-fno-range-check', language : 'fortran') add_global_arguments('-w', language : 'fortran') - add_global_arguments('-O2', language : 'fortran') endif + + py = import('python').find_installation(pure: false) py_dep = py.dependency()