← Back to branch summary

~maddevelopers/mg5amcnlo/2.9.4

« back to all changes in this revision

Viewing changes to vendor/CutTools/src/mpfun90/mpmod90.f90

pass to v2.0.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
vendor/CutTools/src/mpfun90/mpmod90.f90
 
1
module mpdefmod
 
2
 
 
3
!   MPFUN-90 translation modules.
 
4
 
 
5
!   IEEE Fortran-90 version
 
6
!   David H Bailey    2010-07-16
 
7
 
 
8
!   Author:
 
9
!      David H. Bailey
 
10
!      NERSC, Lawrence Berkeley Lab
 
11
!      Mail Stop 50B-2239
 
12
!      Berkeley, CA 94720
 
13
!      Email: dhbailey@lbl.gov
 
14
 
 
15
!   This work was supported by the Director, Office of Science, Division
 
16
!   of Mathematical, Information, and Computational Sciences of the
 
17
!   U.S. Department of Energy under contract number DE-AC03-76SF00098.
 
18
!   See README file accompanying this software for other legal details.
 
19
 
 
20
!   A detailed description of this package, and instructions for compiling 
 
21
!   and testing this program on various specific systems are included in the
 
22
!   README file that accompanies this file.
 
23
 
 
24
!  The following notational scheme is used to designate datatypes below:
 
25
 
 
26
!  A   Alphabetic [i.e. ASCII]
 
27
!  D   Double precision or real*8 [i.e. REAL (KIND (0.D0))]
 
28
!  I   Integer
 
29
!  J   MP integer
 
30
!  Q   MP real
 
31
!  X   Double complex or real*16 [i.e. COMPLEX (KIND (0.D0))]
 
32
!  Z   MP complex
 
33
 
 
34
!  Note that ordinary real*4 and complex*8 types are not included -- if
 
35
!  you have code with these datatypes, convert them to real*8 and complex*16.
 
36
 
 
37
!  The following parameters are all that need to be changed in normal usage:
 
38
 
 
39
!  MPIPL   Initial precision level, in digits.
 
40
!  MPIOU   Initial output precision level, in digits.
 
41
!  MPIEP   Log_10 of initial MP epsilon level.
 
42
 
 
43
use mpfunmod
 
44
implicit none
 
45
integer mpipl, mpiou, mpiep, mpwds
 
46
parameter (mpipl = 2005, mpiou = 56, mpiep = 10 - mpipl)
 
47
 
 
48
!----------------------------------------------------------------------------
 
49
 
 
50
!  *** No code below this point needs to be altered in normal usage.
 
51
 
 
52
parameter (mpwds = mpipl / 7.224719896d0 + 2.d0)
 
53
integer, private:: kdb, mp4, mp24, mp41
 
54
parameter (kdb = kind (0.d0), mp4 = mpwds + 4, mp24 = 2 * mp4, mp41 = mp4 + 1)
 
55
type mp_integer
 
56
  sequence
 
57
  real mpi(mp4)
 
58
end type
 
59
type mp_real
 
60
  sequence
 
61
  real mpr(mp4)
 
62
end type
 
63
type mp_complex
 
64
  sequence
 
65
  real mpc(mp24)
 
66
end type
 
67
type (mp_real), public:: mpl02, mpl10, mppic, mpeps, mplrg, mpsml
 
68
integer, public:: mpnwx, mpoud, new_mpipl, new_mpwds
 
69
 
 
70
contains
 
71
 
 
72
  subroutine mpinit (n_mpipl)
 
73
 
 
74
!  MPINIT must be called at the start of execution in the user's main program.
 
75
!  It sets the numeric precision level, the MP epsilon level, the output
 
76
!  precision level, and computes the constants Pi, Log(2) and Log(10) and
 
77
!  trigonometric factors for the cos/sin routine.  Note that the numeric 
 
78
!  precision level MPNW is temporarily set to MPNWX + 1, in order to permit
 
79
!   extra-accurate calculations of the constants, and then is reset to MPNWX.
 
80
 
 
81
    integer, optional:: n_mpipl
 
82
    integer i, mpnw
 
83
    real*4 t0(mp4+1), t1(mp4+1), t2(mp4+1), t3(mp4+1), t4(mp4+1)
 
84
 
 
85
    if (present (n_mpipl)) then
 
86
      if (n_mpipl > mpipl) then
 
87
        write (mpldb, *) 'mpinit: argument too large'
 
88
        stop
 
89
      endif
 
90
      new_mpipl = n_mpipl
 
91
      new_mpwds = n_mpipl / 7.224719896d0 + 2.d0
 
92
      mpnwx = new_mpwds
 
93
    else
 
94
      new_mpipl = mpipl
 
95
      new_mpwds = mpwds
 
96
      mpnwx = new_mpwds
 
97
    endif
 
98
 
 
99
!   Compute log2, log10 and pi.
 
100
 
 
101
    mpier = 0
 
102
    mpnw = mpnwx + 1
 
103
    call mppi (t1, mpnw) 
 
104
    call mpdmc (2.d0, 0, t0)
 
105
    call mplog (t0, t2, t2, mpnw) 
 
106
    call mpdmc (10.d0, 0, t0)
 
107
    call mplog (t0, t2, t3, mpnw) 
 
108
    call mpnpwr (t0, mpiep, t4, mpnw) 
 
109
    mpnw = mpnwx
 
110
    call mpeq (t1, mppic%mpr, mpnw) 
 
111
    call mpeq (t2, mpl02%mpr, mpnw) 
 
112
    call mpeq (t3, mpl10%mpr, mpnw) 
 
113
    call mpeq (t4, mpeps%mpr, mpnw) 
 
114
 
 
115
!   Allocate and compute the mpcosq and mpsinq arrays, needed for cos and sin.
 
116
 
 
117
    call mpiniq (mpwds, mpnw)
 
118
 
 
119
!   Set mpoud, mplrg and mpsml.
 
120
 
 
121
    mpoud = mpiou
 
122
    mplrg%mpr(1) = 1.
 
123
    mplrg%mpr(2) = 2.e6
 
124
    mplrg%mpr(3) = 1.
 
125
    mplrg%mpr(4) = 0.
 
126
    mpsml%mpr(1) = 1.
 
127
    mpsml%mpr(2) = -2.e6
 
128
    mpsml%mpr(3) = 1.
 
129
    mpsml%mpr(4) = 0.
 
130
    return
 
131
  end subroutine
 
132
 
 
133
  subroutine mpsetprec (num_digits)
 
134
    integer num_digits
 
135
    if (num_digits > new_mpipl) then
 
136
      write (mpldb, *) 'mpsetprec: invalid argument; precision set to ', &
 
137
        new_mpipl, ' digits'
 
138
      mpnwx = new_mpwds
 
139
    else
 
140
      mpnwx = num_digits / 7.224719896d0 + 2.d0
 
141
    endif
 
142
  end subroutine
 
143
 
 
144
  subroutine mpgetprec (num_digits)
 
145
    integer num_digits
 
146
    num_digits = (mpnwx - 2) * 7.224719896d0
 
147
  end subroutine
 
148
 
 
149
  subroutine mpsetprecwords (num_words)
 
150
    integer num_words
 
151
    if (num_words > new_mpwds) then
 
152
      write (mpldb, *) 'mpsetprecwords: invalid argument; precision set to ', &
 
153
        new_mpwds, ' words'
 
154
      mpnwx = new_mpwds
 
155
    else
 
156
      mpnwx = num_words
 
157
    endif
 
158
  end subroutine
 
159
 
 
160
  subroutine mpgetprecwords (num_words)
 
161
    integer num_words
 
162
    num_words = mpnwx
 
163
  end subroutine
 
164
 
 
165
  subroutine mpsetoutputprec (num_digits)
 
166
    integer num_digits
 
167
    if (num_digits > new_mpipl) then
 
168
      write (mpldb, *) &
 
169
        'mpsetoutputprec: invalid argument; output precision set to ', &
 
170
          new_mpipl, ' digits'
 
171
      mpoud = new_mpipl
 
172
    else
 
173
      mpoud = num_digits
 
174
    endif
 
175
  end subroutine
 
176
 
 
177
  subroutine mpgetoutputprec (num_digits)
 
178
    integer num_digits
 
179
    num_digits = mpoud
 
180
  end subroutine
 
181
 
 
182
  subroutine mpgetpar (s, n, k)
 
183
!  MPGETPAR retrieves some ARPREC C++ integer parameters.
 
184
      character*(*), intent(in) :: s
 
185
      integer, intent(out) :: n
 
186
      integer, intent(in), optional :: k
 
187
      
 
188
      if (s == 'mpnw') then 
 
189
        n = mpnwx
 
190
      elseif (s == 'mpidb') then
 
191
        n = mpidb
 
192
      elseif (s == 'mpndb') then
 
193
        n = mpndb
 
194
      elseif (s == 'mpmcr') then
 
195
        n = mpmcr
 
196
      elseif (s == 'mpird') then
 
197
        n = mpird
 
198
      elseif (s == 'mpier') then
 
199
        n = mpier
 
200
      elseif (s == 'mpker') then
 
201
        n = mpker(k)
 
202
      else
 
203
        write (mpldb, 1) s
 
204
1       format ('mpgetpar: invalid parameter name: ',a)
 
205
        n = 0
 
206
      endif
 
207
  end subroutine
 
208
 
 
209
  subroutine mpsetpar (s, n, k)
 
210
!  MPSETPAR sets some ARPREC C++ integer parameters.
 
211
      character*(*), intent(in) :: s
 
212
      integer, intent(in) :: n
 
213
      integer, intent(in), optional :: k
 
214
      
 
215
      if (s == 'mpnw') then 
 
216
        mpnwx = n
 
217
      elseif (s == 'mpidb') then
 
218
        mpidb = n
 
219
      elseif (s == 'mpndb') then
 
220
        mpndb = n
 
221
      elseif (s == 'mpmcr') then
 
222
        mpmcr = n
 
223
      elseif (s == 'mpird') then
 
224
        mpird = n
 
225
      elseif (s == 'mpier') then
 
226
        mpier = n
 
227
      elseif (s == 'mpker') then
 
228
        mpker(k) = n
 
229
      else
 
230
        write (mpldb, 1) s
 
231
1       format ('mpsetpar: invalid parameter name: ',a)
 
232
      endif
 
233
  end subroutine
 
234
 
 
235
  subroutine mpeform (a, n1, n2, b)
 
236
    type (mp_real) a
 
237
    integer n1, n2
 
238
    character*1 b(n1)
 
239
    integer mpnw
 
240
    mpnw = mpnwx
 
241
    call mpeformx (a%mpr, n1, n2, b, mpnw)
 
242
    return
 
243
  end subroutine
 
244
    
 
245
  subroutine mpfform (a, n1, n2, b)
 
246
    type (mp_real) a
 
247
    integer n1, n2
 
248
    character*1 b(n1)
 
249
    integer mpnw
 
250
    mpnw = mpnwx
 
251
    call mpfformx (a%mpr, n1, n2, b, mpnw)
 
252
    return
 
253
  end subroutine
 
254
    
 
255
  subroutine mpdexc (a, l, b, mpnw)
 
256
 
 
257
!   This routine converts the character*1 string A, which
 
258
!   represents a multiprecision number in Fortran style, i.e.
 
259
!   '1234567890' or '1.23456789D-21', into standard MP binary format.
 
260
!   This routine is not intended to be called directly by the user.
 
261
 
 
262
    integer i, i1, l, l1, l2, mpnw
 
263
    character*1 a(l), c(mpipl+100)
 
264
    real b(mpnw+4)
 
265
 
 
266
    do i = 1, l
 
267
      if (a(i) .eq. 'D' .or. a(i) .eq. 'E' .or. a(i) .eq. 'd' &
 
268
        .or. a(i) .eq. 'e') goto 100
 
269
    enddo
 
270
 
 
271
    call mpinpc (a, l, b, mpnw) 
 
272
    goto 110
 
273
 
 
274
100 i1 = i
 
275
    l1 = i - 1
 
276
    l2 = l - i
 
277
    c(1) = '1'
 
278
    c(2) = '0'
 
279
    c(3) = '^'
 
280
 
 
281
    do i = 1, l2
 
282
      c(i+3) = a(i+i1)
 
283
    enddo
 
284
 
 
285
    c(l2+4) = 'x'
 
286
 
 
287
    do i = 1, l1
 
288
      c(i+l2+4) = a(i)
 
289
    enddo
 
290
 
 
291
    call mpinpc (c, l1 + l2 + 4, b, mpnw) 
 
292
110 return
 
293
  end subroutine
 
294
 
 
295
subroutine mpinp (iu, a, cs, mpnw)
 
296
 
 
297
!   This routine reads the MP number A from logical unit IU.  CS is a scratch
 
298
!   array of type CHARACTER*1.  CS must be dimensioned at least 7.225*MPNW
 
299
!   + 100.   The digits of A may span more than one line.  A comma at the end
 
300
!   of the last line denotes the end of the MP number.  The input lines may not
 
301
!   exceed 200 characters in length.  Embedded blanks are allowed anywhere.
 
302
!   However, if the input number contains more than 80 embedded blanks, then
 
303
!   the dimension of CS must be increased by a corresponding amount.  The
 
304
!   exponent is optional in the input number, but if present it must appear
 
305
!   first.  Two examples:
 
306
 
 
307
!   1073741824.,
 
308
!   10 ^  -4 x  3.14159 26535 89793 23846 26433 83279
 
309
!     50288 41971 69399 37510,
 
310
 
 
311
!   Max SP space for A: MPNW + 4 cells.
 
312
 
 
313
integer i, iu, l, l1, mpnw, nn
 
314
character*200 line
 
315
character*1 cs(*)
 
316
real a(mpnw+2)
 
317
 
 
318
if (mpier .ne. 0) then
 
319
  if (mpier .eq. 99) call mpabrt
 
320
  a(1) = 0.
 
321
  a(2) = 0.
 
322
  return
 
323
endif
 
324
l = 0
 
325
nn = mpipl + 100
 
326
 
 
327
100 continue
 
328
read (iu, '(A)', end = 200) line
 
329
 
 
330
do i = 200, 1, -1
 
331
  if (line(i:i) .ne. ' ') goto 110
 
332
enddo
 
333
 
 
334
i = 0
 
335
goto 100
 
336
 
 
337
110 continue
 
338
l1 = i
 
339
 
 
340
do i = 1, l1
 
341
  if (line(i:i) == ',') goto 150
 
342
  if (l + 1 <= nn) then
 
343
    l = l + 1
 
344
    cs(l) = line(i:i)
 
345
  endif
 
346
enddo
 
347
 
 
348
goto 100
 
349
 
 
350
150  continue
 
351
 
 
352
call mpinpc (cs, l, a, mpnw)
 
353
goto 300
 
354
 
 
355
200  continue
 
356
 
 
357
if (mpker(72) .ne. 0) then
 
358
  write (mpldb, 1)
 
359
1 format ('*** MPINP: End-of-file encountered.')
 
360
  mpier = 72
 
361
  if (mpker(mpier) .eq. 2) call mpabrt
 
362
endif
 
363
 
 
364
300 return
 
365
end subroutine
 
366
 
 
367
subroutine mpinpc (a, n, b, mpnw)
 
368
 
 
369
!   Converts the CHARACTER*1 array A of length N into the MP number B.  The
 
370
!   string A must be in the format '10^s a x tb.c' where a, b and c are digit
 
371
!   strings; s and t are '-', '+' or blank; x is either 'x' or '*'.  Blanks may
 
372
!   be embedded anywhere.  The digit string a is limited to nine digits and
 
373
!   80 total characters, including blanks.  The exponent portion (i.e. the
 
374
!   portion up to and including x) and the period may optionally be omitted.
 
375
!   Debug output starts with MPIDB = 7.
 
376
 
 
377
!   Max SP space for B: MPNW + 4 cells.
 
378
 
 
379
!   The following example shows how this routine may be used to input a MP
 
380
!   number:
 
381
 
 
382
!   CHARACTER*1 CX(800)
 
383
!   READ (1, '(80A1)') (CX(I), I = 1, ND)
 
384
!   CALL MPINPC (CX, ND, B)
 
385
 
 
386
integer i, ib, id, ier, ip, is, it, i1, i2, k0, k1, k2, l1, mpnw, n, nb, &
 
387
  nn, no, nws, n5
 
388
double precision bi
 
389
character*1 a(n), ai
 
390
character*10 dig
 
391
character*80 ca
 
392
parameter (dig = '0123456789')
 
393
real b(mpnw+4), f(8), s(3*mpnw+15)
 
394
! real*8 mpdigin
 
395
 
 
396
if (mpier .ne. 0) then
 
397
  if (mpier .eq. 99) call mpabrt
 
398
  b(1) = 0.
 
399
  b(2) = 0.
 
400
  return
 
401
endif
 
402
if (mpidb .ge. 7) then
 
403
  no = min (n, int (7.225 * mpndb) + 20)
 
404
  write (mpldb, 1) (a(i), i = 1, no)
 
405
1 format ('MPINPC I'/(78a1))
 
406
endif
 
407
 
 
408
n5 = mpnw + 5
 
409
k0 = 1
 
410
k1 = k0 + n5
 
411
k2 = k1 + n5
 
412
nws = mpnw
 
413
mpnw = mpnw + 1
 
414
i1 = 1
 
415
nn = 0
 
416
 
 
417
!   Find the carat, period, plus or minus sign, whichever comes first.
 
418
 
 
419
do i = 1, n
 
420
  ai = a(i)
 
421
  if (ai .eq. '^') goto 110
 
422
  if (ai .eq. '.' .or. ai .eq. '+' .or. ai .eq. '-') goto 160
 
423
enddo
 
424
 
 
425
goto 160
 
426
 
 
427
!   Make sure number preceding the carat is 10.
 
428
 
 
429
110 continue
 
430
 
 
431
i2 = i - 1
 
432
if (i2 .gt. 80) then
 
433
  ier = 1
 
434
  goto 210
 
435
endif
 
436
ca = ' '
 
437
 
 
438
do i = 1, i2
 
439
  ai = a(i)
 
440
  if (ai .eq. ' ') then
 
441
    goto 120
 
442
  elseif (index (dig, ai) .eq. 0) then
 
443
    ier = 2
 
444
    goto 210
 
445
  endif
 
446
  ca(i:i) = ai
 
447
120  continue
 
448
enddo
 
449
 
 
450
nn = mpdigin (ca, 80)
 
451
if (nn .ne. 10) then
 
452
  ier = 3
 
453
  goto 210
 
454
endif
 
455
i1 = i2 + 2
 
456
 
 
457
!   Find the x or *.
 
458
 
 
459
do i = i1, n
 
460
  ai = a(i)
 
461
  if (ai .eq. 'x' .or. ai .eq. '*') goto 140
 
462
enddo
 
463
 
 
464
ier = 4
 
465
goto 210
 
466
 
 
467
!   Convert the exponent.
 
468
 
 
469
140  i2 = i - 1
 
470
l1 = i2 - i1 + 1
 
471
if (l1 .gt. 80) then
 
472
  ier = 5
 
473
  goto 210
 
474
endif
 
475
ca = ' '
 
476
id = 0
 
477
is = 1
 
478
 
 
479
do i = 1, l1
 
480
  ai = a(i+i1-1)
 
481
  if (ai .eq. ' ' .or. ai .eq. '+') then
 
482
    goto 150
 
483
  elseif (ai .eq. '-' .and. id .eq. 0) then
 
484
    id = 1
 
485
    is = -1
 
486
    ca(i:i) = ' '
 
487
  else
 
488
    if (index (dig, ai) .eq. 0) then
 
489
      ier = 6
 
490
      goto 210
 
491
    endif
 
492
    id = 1
 
493
    ca(i:i) = ai
 
494
  endif
 
495
150  continue
 
496
enddo
 
497
 
 
498
nn = is * mpdigin (ca, 80)
 
499
i1 = i2 + 2
 
500
 
 
501
!   Find the next nonblank character.
 
502
 
 
503
160  do i = i1, n
 
504
  if (a(i) .ne. ' ') goto 180
 
505
enddo
 
506
 
 
507
ier = 7
 
508
goto 210
 
509
 
 
510
!   Check if the nonblank character is a plus or minus sign.
 
511
 
 
512
180 continue
 
513
 
 
514
i1 = i
 
515
if (a(i1) .eq. '+') then
 
516
  i1 = i1 + 1
 
517
  is = 1
 
518
elseif (a(i1) .eq. '-') then
 
519
  i1 = i1 + 1
 
520
  is = -1
 
521
else
 
522
  is = 1
 
523
endif
 
524
nb = 0
 
525
ib = 0
 
526
id = 0
 
527
ip = 0
 
528
s(k2) = 0.
 
529
s(k2+1) = 0.
 
530
f(1) = 1.
 
531
f(2) = 0.
 
532
it = 0
 
533
 
 
534
190 continue
 
535
 
 
536
ip = 0
 
537
ca(1:6) = '000000'
 
538
 
 
539
!   Scan for digits, looking for the period also.  On the first pass we just
 
540
!   count, so that on the second pass it will come out right.
 
541
 
 
542
do i = i1, n
 
543
  ai = a(i)
 
544
  if (ai .eq. ' ') then
 
545
  elseif (ai .eq. '.') then
 
546
    if (ip .ne. 0) then
 
547
      ier = 8
 
548
      goto 210
 
549
    endif
 
550
    ip = id
 
551
  elseif (index (dig, ai) .eq. 0) then
 
552
    ier = 9
 
553
    goto 210
 
554
  else
 
555
    ib = ib + 1
 
556
    id = id + 1
 
557
    ca(ib:ib) = ai
 
558
  endif
 
559
  if (ib .eq. 6 .or. i .eq. n .and. ib .ne. 0) then
 
560
    if (it .ne. 0) then
 
561
      nb = nb + 1
 
562
      bi = mpdigin (ca(1:6), 6)
 
563
      call mpmuld (s(k2), 1.d6, 0, s(k0), mpnw) 
 
564
      if (bi .ne. 0) then
 
565
        f(1) = 1.
 
566
        f(3) = bi
 
567
      else
 
568
        f(1) = 0.
 
569
      endif
 
570
      call mpadd (s(k0), f, s(k2), mpnw) 
 
571
      ca(1:6) = '000000'
 
572
    endif
 
573
    if (i .ne. n) ib = 0
 
574
  endif
 
575
enddo
 
576
 
 
577
if (it .eq. 0) then
 
578
  ib = 6 - ib
 
579
  if (ib .eq. 6) ib = 0
 
580
  it = 1
 
581
  goto 190
 
582
endif
 
583
if (is .eq. -1) s(k2) = - s(k2)
 
584
if (ip .eq. 0) ip = id
 
585
nn = nn + ip - id
 
586
f(1) = 1.
 
587
f(3) = 10.
 
588
call mpnpwr (f, nn, s(k0), mpnw) 
 
589
call mpmul (s(k2), s(k0), s(k1), mpnw) 
 
590
call mpeq (s(k1), b, mpnw) 
 
591
mpnw = nws
 
592
call mproun (b, mpnw) 
 
593
 
 
594
if (mpidb .ge. 7) then
 
595
  no = min (int (abs (b(1))), mpndb) + 2
 
596
  write (mpldb, 2) (b(i), i = 1, no)
 
597
2 format ('MPINPC O'/(6f12.0))
 
598
endif
 
599
goto 220
 
600
 
 
601
210 continue
 
602
 
 
603
if (mpker(41) .ne. 0) then
 
604
  write (mpldb, 3)
 
605
3 format ('*** MPINPC: Syntax error in literal string.')
 
606
  mpier = 41
 
607
  if (mpker(mpier) .eq. 2) call mpabrt
 
608
  mpnw = nws
 
609
endif
 
610
 
 
611
220  return
 
612
end subroutine
 
613
 
 
614
subroutine mpout (iu, a, la, cs, mpnw)
 
615
 
 
616
!   This routine writes the exponent plus LA mantissa digits of the MP number
 
617
!   A to logical unit IU.  CS is a scratch array of type CHARACTER*1.  CS must
 
618
!   be dimensioned at least LA + 25.  The digits of A may span more than one
 
619
!   line.  A comma is placed at the end of the last line to denote the end of
 
620
!   the MP number.  Here is an example of the output:
 
621
 
 
622
!   10 ^  -4 x  3.14159265358979323846264338327950288419716939937510,
 
623
 
 
624
integer i, iu, l, la, ll, mpnw, nws
 
625
character*1 cs(la+25)
 
626
real a(mpnw+2)
 
627
 
 
628
if (mpier .ne. 0) return
 
629
 
 
630
nws = mpnw
 
631
ll = la / log10 (mpbdx) + 2.d0
 
632
mpnw = min (mpnw, ll)
 
633
call mpoutc (a, cs, l, mpnw) 
 
634
mpnw = nws
 
635
l = min (l, la + 20) + 1
 
636
cs(l) = ','
 
637
write (iu, '(78A1)') (cs(i), i = 1, l)
 
638
 
 
639
return
 
640
end subroutine
 
641
 
 
642
subroutine mpoutc (a, b, n, mpnw)
 
643
 
 
644
!   Converts the MP number A into character form in the CHARACTER*1 array B.
 
645
!   N (an output parameter) is the length of the output.  In other words, B is
 
646
!   contained in B(1), ..., B(N).  The format is analogous to the Fortran
 
647
!   exponential format (E format), except that the exponent is placed first.
 
648
!   Debug output starts with MPIDB = 7.
 
649
 
 
650
!   Max CHARACTER*1 space for B: 7.225 * MPNW + 30 cells.
 
651
 
 
652
!   This routine is called by MPOUT, but it may be directly called by the user
 
653
!   if desired for custom output.  Example:
 
654
 
 
655
!   CHARACTER*1 CX(800)
 
656
!   CALL MPOUTC (A, CX, ND)
 
657
!   WRITE (1, '(20A1/(72A1))') (CX(I), I = 1, ND)
 
658
 
 
659
integer i, ia, ix, j, k0, k1, l, mpnw, na, nl, n5, nws, n, no, nx
 
660
character*1 b(n)
 
661
character*16 ca
 
662
real*8 aa, al2, con, t1
 
663
parameter (al2 = 0.301029995663981195d0, con = 0.8304820235d0)
 
664
real a(mpnw+2), f(8), s(2*mpnw+10)
 
665
real*8 an
 
666
! character*16 mpdigout
 
667
 
 
668
if (mpier .ne. 0) then
 
669
  if (mpier .eq. 99) call mpabrt
 
670
  b(1) = ' '
 
671
  n = 0
 
672
  return
 
673
endif
 
674
if (mpidb .ge. 7) then
 
675
  no = min (int (abs (a(1))), mpndb) + 2
 
676
  write (mpldb, 1) (a(i), i = 1, no)
 
677
1 format ('MPOUTC I'/(6f12.0))
 
678
endif
 
679
 
 
680
ia = sign (1., a(1))
 
681
na = min (int (abs (a(1))), mpnw)
 
682
n5 = mpnw + 5
 
683
k0 = 1
 
684
k1 = k0 + n5
 
685
nws = mpnw
 
686
mpnw = mpnw + 1
 
687
f(1) = 1.
 
688
f(2) = 0.
 
689
f(3) = 10.
 
690
 
 
691
!   Determine exact power of ten for exponent.
 
692
 
 
693
if (na .ne. 0) then
 
694
  aa = a(3)
 
695
  if (na .ge. 2) aa = aa + mprdx * a(4)
 
696
  if (na .ge. 3) aa = aa + mprx2 * a(5)
 
697
  if (na .ge. 4) aa = aa + mprdx * mprx2 * a(6)
 
698
  t1 = al2 * mpnbt * a(2) + log10 (aa)
 
699
  if (t1 .ge. 0.d0) then
 
700
    nx = t1
 
701
  else
 
702
    nx = t1 - 1.d0
 
703
  endif
 
704
  call mpnpwr (f, nx, s(k0), mpnw) 
 
705
  call mpdiv (a, s(k0), s(k1), mpnw) 
 
706
 
 
707
!   If we didn't quite get it exactly right, multiply or divide by 10 to fix.
 
708
 
 
709
100 continue
 
710
 
 
711
    if (s(k1+1) .lt. 0.) then
 
712
    nx = nx - 1
 
713
    call mpmuld (s(k1), 10.d0, 0, s(k0), mpnw) 
 
714
    call mpeq (s(k0), s(k1), mpnw) 
 
715
    goto 100
 
716
  elseif (s(k1+2) .ge. 10.) then
 
717
    nx = nx + 1
 
718
    call mpdivd (s(k1), 10.d0, 0, s(k0), mpnw) 
 
719
    call mpeq (s(k0), s(k1), mpnw) 
 
720
    goto 100
 
721
  endif
 
722
  s(k1) = abs (s(k1))
 
723
else
 
724
  nx = 0
 
725
endif
 
726
 
 
727
!   Place exponent first instead of at the very end as in Fortran.
 
728
 
 
729
b(1) = '1'
 
730
b(2) = '0'
 
731
b(3) = ' '
 
732
b(4) = '^'
 
733
ca = mpdigout (dble (nx), 10)
 
734
 
 
735
do i = 1, 10
 
736
  b(i+4) = ca(i:i)
 
737
enddo
 
738
 
 
739
b(15) = ' '
 
740
b(16) = 'x'
 
741
b(17) = ' '
 
742
 
 
743
!   Insert sign and first digit.
 
744
 
 
745
if (ia .eq. -1) then
 
746
  b(18) = '-'
 
747
else
 
748
  b(18) = ' '
 
749
endif
 
750
if (na .ne. 0) then
 
751
  an = s(k1+2)
 
752
else
 
753
  an = 0
 
754
endif
 
755
ca = mpdigout (an, 1)
 
756
b(19) = ca(1:1)
 
757
b(20) = '.'
 
758
ix = 20
 
759
if (na .eq. 0) goto 190
 
760
f(3) = an
 
761
call mpsub (s(k1), f, s(k0), mpnw) 
 
762
if (s(k0) .eq. 0) goto 190
 
763
call mpmuld (s(k0), 1.d6, 0, s(k1), mpnw) 
 
764
nl = max (mpnw * log10 (mpbdx) / 6.d0 - 1.d0, 1.d0)
 
765
nl = min (nl, mpoud/6 + 1)
 
766
 
 
767
!   Insert the digits of the remaining words.
 
768
 
 
769
do j = 1, nl
 
770
  if (s(k1+1) .eq. 0.) then
 
771
    an = s(k1+2)
 
772
    f(1) = 1.
 
773
    f(3) = an
 
774
  else
 
775
    f(1) = 0.
 
776
    an = 0.
 
777
  endif
 
778
  ca = mpdigout (an, 6)
 
779
 
 
780
  do i = 1, 6
 
781
    if (ca(i:i) == ' ') ca(i:i) = '0'
 
782
    b(i+ix) = ca(i:i)
 
783
  enddo
 
784
 
 
785
  ix = ix + 6
 
786
  call mpsub (s(k1), f, s(k0), mpnw) 
 
787
  call mpmuld (s(k0), 1.d6, 0, s(k1), mpnw) 
 
788
  if (s(k1) .eq. 0.) goto 140
 
789
enddo
 
790
 
 
791
!   Check if trailing zeroes should be trimmed.
 
792
 
 
793
j = nl + 1
 
794
 
 
795
140  l = ix
 
796
if (b(l) .eq. '0' .and. b(l-1) .eq. '0' .or. (j .gt. nl .and. b(l-2) .eq. '0' &
 
797
   .and. b(l-3) .eq. '0')) then
 
798
  b(l) = ' '
 
799
  b(l-1) = ' '
 
800
 
 
801
  do i = l - 2, 21, -1
 
802
    if (b(i) .ne. '0') then
 
803
      ix = i
 
804
      goto 190
 
805
    endif
 
806
    b(i) = ' '
 
807
  enddo
 
808
 
 
809
  ix = 20
 
810
 
 
811
!   Check if trailing nines should be rounded up.
 
812
 
 
813
elseif (j .gt. nl .and. b(l-2) .eq. '9' .and. b(l-3) .eq. '9') then
 
814
  b(l) = ' '
 
815
  b(l-1) = ' '
 
816
 
 
817
  do i = l - 2, 21, -1
 
818
    if (b(i) .ne. '9') goto 180
 
819
    b(i) = ' '
 
820
  enddo
 
821
 
 
822
!   We have rounded away all digits to the right of the decimal point, and the
 
823
!   digit to the left of the digit is a 9.  Set the digit to 1 and increase
 
824
!   the exponent by one.
 
825
 
 
826
  ix = 20
 
827
  if (b(19) .eq. '9') then
 
828
    b(19) = '1'
 
829
    ca = mpdigout (dble (nx+1), 10)
 
830
 
 
831
    do i = 1, 10
 
832
      b(i+4) = ca(i:i)
 
833
    enddo
 
834
  else
 
835
    ca = b(19)
 
836
    an = mpdigin (ca, 1)
 
837
    ca = mpdigout (an + 1.d0, 1)
 
838
    b(19) = ca(1:1)
 
839
  endif
 
840
  goto 190
 
841
 
 
842
180 continue
 
843
 
 
844
  ca = b(i)
 
845
  an = mpdigin (ca, 1)
 
846
  ca = mpdigout (an + 1.d0, 1)
 
847
  b(i) = ca(1:1)
 
848
  ix = i
 
849
endif
 
850
 
 
851
190 continue
 
852
 
 
853
n = min (ix, mpoud + 20)
 
854
mpnw = nws
 
855
if (mpidb .ge. 7) then
 
856
  no = min (n, 6 * mpndb + 20)
 
857
  write (mpldb, 2) (b(i), i = 1, no)
 
858
2 format ('MPOUTC O'/(78a1))
 
859
endif
 
860
return
 
861
end subroutine
 
862
 
 
863
recursive subroutine mpoutcx (a, b, n, mpnw)
 
864
 
 
865
!   Converts the MP number A into character form in the CHARACTER*1 array B.
 
866
!   N (an output parameter) is the length of the output.  In other words, B is
 
867
!   contained in B(1), ..., B(N).  The format is analogous to the Fortran
 
868
!   exponential format (E format), except that the exponent is placed first.
 
869
!   Before calling MPOUTX, the arrays UU1 and UU2 must be initialized by
 
870
!   calling MPINIX.  For modest levels of precision, use MPOUTC.  Debug output
 
871
!   starts with MPIDB = 7.
 
872
 
 
873
!   Max CHARACTER*1 space for B: 7.225 * MPNW + 30 cells.
 
874
 
 
875
implicit none
 
876
integer i, ia, ie, ie1, ie2, i1, i2, k0, k1, k2, k3, k4, m1, m2, &
 
877
  mpnw, mpnws, n, na, nb1, nb2, ncr, no, n4
 
878
double precision al2, t1, t2, t3
 
879
character*1 b(*), b1(8*mpnw+30), b2(8*mpnw+30)
 
880
character*10 dig
 
881
character*16 c1, c2
 
882
parameter (al2 = 0.301029995663981195d0, dig = '0123456789')
 
883
real a(mpnw+2), s(5*mpnw+20)
 
884
 
 
885
if (mpier .ne. 0) then
 
886
  if (mpier .eq. 99) call mpabrt
 
887
  b(1) = ' '
 
888
  n = 0
 
889
  return
 
890
endif
 
891
if (mpidb .ge. 7) then
 
892
  no = min (int (abs (a(1))), mpndb) + 2
 
893
  write (mpldb, 1) (a(i), i = 1, no)
 
894
1 format ('MPOUTCX I'/(6f12.0))
 
895
endif
 
896
 
 
897
ia = sign (1., a(1))
 
898
na = min (int (abs (a(1))), mpnw)
 
899
n4 = mpnw + 4
 
900
k0 = 1
 
901
k1 = k0 + n4
 
902
k2 = k1 + n4
 
903
k3 = k2 + n4
 
904
k4 = k3 + n4
 
905
ncr = 2 ** mpmcr
 
906
 
 
907
!   Check if actual precision level of argument is too low to justify the
 
908
!   advanced routine.
 
909
 
 
910
if (na .le. ncr) then
 
911
  call mpoutc (a, b, n, mpnw) 
 
912
  goto 110
 
913
endif
 
914
 
 
915
!   Normalize input to an integer by multiplying by a suitable power of 10.
 
916
 
 
917
t1 = a(3) + mprdx * a(4) + mprx2 * a(5)
 
918
t2 = log10 (t1)
 
919
m1 = max (al2 * mpnbt * (abs (a(1)) - a(2)) - t2, 0.d0)
 
920
call mpdmc (10.d0, 0, s(k0))
 
921
call mpnpwx (s(k0), m1, s(k2), mpnw) 
 
922
call mpmulx (a, s(k2), s(k1), mpnw) 
 
923
s(k1) = abs (s(k1))
 
924
 
 
925
!   Split large integer into two approximately equal decimal sections.
 
926
 
 
927
call mpmdc (s(k1), t1, i1)
 
928
call dpdec (t1, i1, t2, i2) 
 
929
m2 = i2 / 2
 
930
call mpnpwx (s(k0), m2, s(k3), mpnw) 
 
931
call mpdivx (s(k1), s(k3), s(k0), mpnw) 
 
932
call mpinfr (s(k0), s(k2), s(k4), mpnw) 
 
933
call mpmulx (s(k2), s(k3), s(k0), mpnw) 
 
934
call mpsub (s(k1), s(k0), s(k3), mpnw) 
 
935
 
 
936
!   Recursively convert each section.
 
937
 
 
938
mpnws = mpnw
 
939
mpnw = s(k2) + 1
 
940
call mpoutcx (s(k2), b1, nb1, mpnw) 
 
941
mpnw = s(k3) + 1
 
942
call mpoutcx (s(k3), b2, nb2, mpnw) 
 
943
mpnw = mpnws
 
944
 
 
945
!   Obtain decimal exponents from each section.
 
946
 
 
947
c1 = ' '
 
948
c2 = ' '
 
949
 
 
950
do i = 1, 10
 
951
  c1(i:i) = b1(i+4)
 
952
  c2(i:i) = b2(i+4)
 
953
enddo
 
954
 
 
955
read (c1, '(I10)') ie1
 
956
read (c2, '(I10)') ie2
 
957
 
 
958
!   Set exponent of result.
 
959
 
 
960
ie = ie1 + m2 - m1
 
961
write (c1, '(I14)') ie
 
962
 
 
963
do i = 1, 4
 
964
  b(i) = b1(i)
 
965
enddo
 
966
 
 
967
do i = 5, 14
 
968
  b(i) = c1(i:i)
 
969
enddo
 
970
 
 
971
!   Copy mantissa of first section.
 
972
 
 
973
do i = 15, nb1
 
974
  b(i) = b1(i)
 
975
enddo
 
976
 
 
977
i1 = ie1 + m2 - ie2 + 19
 
978
 
 
979
!   If first section is too long, then round trailing digits (probably 9s).
 
980
 
 
981
if (nb1 .gt. i1) then
 
982
  i2 = index (dig, b(i1+1)) - 1
 
983
  if (i2 .ge. 5) then
 
984
    do i = i1, 21, -1
 
985
      if (b(i) .ne. '9') goto 100
 
986
      b(i) = '0'
 
987
    enddo
 
988
 
 
989
    write (mpldb, 2)
 
990
2   format ('*** MPOUTCX: Exceptional case -- contact DHB.')
 
991
    stop
 
992
 
 
993
100 i2 = index (dig, b(i)) - 1
 
994
    write (c1, '(I1)') i2 + 1
 
995
    b(i) = c1(1:1)
 
996
  endif
 
997
elseif (nb1 .lt. i1) then
 
998
 
 
999
!   If first section is too short, then insert zeroes in gap.
 
1000
 
 
1001
  do i = nb1 + 1, i1
 
1002
    b(i) = '0'
 
1003
  enddo
 
1004
endif
 
1005
 
 
1006
!   Copy mantissa of second section.
 
1007
 
 
1008
b(i1+1) = b2(19)
 
1009
n = min (i1 + nb2 - 19, int (7.225 * mpnw + 30))
 
1010
 
 
1011
do i = i1 + 1, n
 
1012
  b(i) = b2(i-i1+19)
 
1013
enddo
 
1014
 
 
1015
!   Fix sign.
 
1016
 
 
1017
if (ia .eq. -1) b(18) = '-'
 
1018
 
 
1019
110 continue
 
1020
 
 
1021
if (mpidb .ge. 7) then
 
1022
  no = min (n, 6 * mpndb + 20)
 
1023
  write (mpldb, 3) (b(i), i = 1, no)
 
1024
3 format ('MPOUTCX O'/(78a1))
 
1025
endif
 
1026
 
 
1027
return
 
1028
end subroutine
 
1029
 
 
1030
  real*8 function mpdigin (ca, n)
 
1031
    implicit none
 
1032
    real*8 d1
 
1033
    character*(*), ca
 
1034
    character*16 digits
 
1035
    integer i, k, n
 
1036
    parameter (digits = '0123456789')
 
1037
 
 
1038
    d1 = 0.d0
 
1039
 
 
1040
    do i = 1, n
 
1041
      k = index (digits, ca(i:i)) - 1
 
1042
      if (k < 0) then
 
1043
        write (mpldb, *) 'mpdigin: non-digit in character string'
 
1044
      elseif (k <= 9) then
 
1045
        d1 = 10.d0 * d1 + k
 
1046
      endif
 
1047
    enddo
 
1048
 
 
1049
    mpdigin = d1
 
1050
  end function
 
1051
 
 
1052
  character*16 function mpdigout (a, n)
 
1053
    implicit none
 
1054
    real*8 a, d1, d2
 
1055
    character*16 ca, digits
 
1056
    parameter (digits = '0123456789')
 
1057
    integer i, is, k, n
 
1058
 
 
1059
    ca = ' '
 
1060
    is = sign (1.d0, a)
 
1061
    d1 = abs (a)
 
1062
 
 
1063
    do i = n, 1, -1
 
1064
      d2 = aint (d1 / 10.d0)
 
1065
      k = 1.d0 + (d1 - 10.d0 * d2)
 
1066
      d1 = d2
 
1067
      ca(i:i) = digits(k:k)
 
1068
      if (d1 == 0.d0) goto 100
 
1069
    enddo
 
1070
 
 
1071
    i = 0
 
1072
 
 
1073
100  continue
 
1074
 
 
1075
    if (is < 0 .and. i > 1) then
 
1076
      ca(i-1:i-1) = '-'
 
1077
    elseif (i == 0 .or. is < 0 .and. i == 1) then
 
1078
      ca = '****************'
 
1079
    endif
 
1080
 
 
1081
    mpdigout = ca
 
1082
    return
 
1083
  end function
 
1084
 
 
1085
subroutine mpeformx (a, n1, n2, b, mpnw)
 
1086
 
 
1087
!   This routine converts the MP number A to E format, i.e. E N1.N2.
 
1088
!   B is the output array (type CHARACTER*1) of size N1.
 
1089
 
 
1090
      integer i, j, k, lex, n, n1, n2, mpnw
 
1091
      real*4 a(mpnw+4)
 
1092
      character*1 b(n1), c(8*mpnw+100)
 
1093
 
 
1094
      if (n1 > mpoud) then
 
1095
        write (mpldb, '("*** mpeformx: mpoud must exceed n1")')
 
1096
        goto 110
 
1097
      endif
 
1098
      call mpoutc (a, c, n, mpnw)
 
1099
 
 
1100
!   Find length of exponent field.
 
1101
 
 
1102
      do i = 5, 14
 
1103
        if (c(i) /= ' ') goto 100
 
1104
      enddo
 
1105
 
 
1106
100   continue
 
1107
 
 
1108
      lex = 15 - i
 
1109
      k = n1 - lex - n2 - 4
 
1110
 
 
1111
!   Check for overflow of field length.
 
1112
 
 
1113
      if (k < 0) then
 
1114
         do j = 1, n1
 
1115
            b(j) = '*'
 
1116
         enddo
 
1117
 
 
1118
         goto 110
 
1119
      endif
 
1120
 
 
1121
!   Copy characters to appropriate positions.
 
1122
 
 
1123
      do j = 1, k
 
1124
        b(j) = ' '
 
1125
      enddo
 
1126
 
 
1127
      do j = 1, min (n2 + 3, n - 17)
 
1128
        b(j+k) = c(j+17)
 
1129
      enddo
 
1130
 
 
1131
      do j = n - 16, n2 + 3
 
1132
        b(j+k) = '0'
 
1133
      enddo
 
1134
 
 
1135
      b(k+n2+4) = 'e'
 
1136
 
 
1137
      do j = 1, lex
 
1138
        b(j+k+n2+4) = c(i+j-1)
 
1139
      enddo
 
1140
 
 
1141
110   continue
 
1142
 
 
1143
  return
 
1144
  end subroutine
 
1145
 
 
1146
subroutine mpfformx (a, n1, n2, b, mpnw)
 
1147
 
 
1148
!   This routine converts the MP number A to F format, i.e. F N1.N2.
 
1149
!   B is the output array (type CHARACTER*1) of size N1.
 
1150
 
 
1151
integer i, ix, kx, ls, lz, mpnw, mx, n, n1, n2, nx
 
1152
real a(mpnw+2)
 
1153
character*1 b(n1), c(8*mpnw+100)
 
1154
character*16 chr16
 
1155
! real*8 mpdigin
 
1156
 
 
1157
if (n1 > mpoud) then
 
1158
  write (mpldb, '("*** mpfformx: mpoud must exceed n1")')
 
1159
  goto 200
 
1160
endif
 
1161
 
 
1162
call mpoutc (a, c, n, mpnw) 
 
1163
chr16 = ' '
 
1164
 
 
1165
do i = 1, 10
 
1166
  chr16(i:i) = c(i+4)
 
1167
enddo
 
1168
 
 
1169
ix = mpdigin (chr16, 16)
 
1170
if (a(1) .ge. 0.) then
 
1171
  ls = 0
 
1172
else
 
1173
  ls = 1
 
1174
endif
 
1175
if (ix .ge. 0 .and. a(1) .ne. 0.) then
 
1176
  lz = 0
 
1177
else
 
1178
  lz = 1
 
1179
endif
 
1180
mx = max (ix, 0)
 
1181
 
 
1182
!   Check for overflow of field length.
 
1183
 
 
1184
if (ls + lz + mx + n2 + 2 .gt. n1) then
 
1185
  do i = 1, n1
 
1186
    b(i) = '*'
 
1187
  enddo
 
1188
 
 
1189
  goto 200
 
1190
endif
 
1191
 
 
1192
!   Check if a zero should be output.
 
1193
 
 
1194
if (a(1) .eq. 0 .or. -ix .gt. n2) then
 
1195
  do i = 1, n1 - n2 - 2
 
1196
    b(i) = ' '
 
1197
  enddo
 
1198
 
 
1199
  b(n1-n2-1) = '0'
 
1200
  b(n1-n2) = '.'
 
1201
 
 
1202
  do i = 1, n2
 
1203
    b(i+n1-n2) = '0'
 
1204
  enddo
 
1205
 
 
1206
  goto 200
 
1207
endif
 
1208
 
 
1209
!   Process other cases.
 
1210
 
 
1211
do i = 1, n1 - n2 - mx - 2
 
1212
  b(i) = ' '
 
1213
enddo
 
1214
 
 
1215
if (a(1) .lt. 0.) b(n1-n2-mx-2) = '-'
 
1216
if (ix .ge. 0) then
 
1217
  b(n1-n2-ix-1) = c(19)
 
1218
  kx = min (n - 20, ix)
 
1219
 
 
1220
  do i = 1, kx
 
1221
    b(i+n1-n2-ix-1) = c(i+20)
 
1222
  enddo
 
1223
 
 
1224
  do i = kx + 1, ix
 
1225
    b(i+n1-n2-ix-1) = '0'
 
1226
  enddo
 
1227
 
 
1228
  b(n1-n2) = '.'
 
1229
  kx = max (min (n - ix - 20, n2), 0)
 
1230
 
 
1231
  do i = 1, kx
 
1232
    b(i+n1-n2) = c(i+ix+20)
 
1233
  enddo
 
1234
 
 
1235
  do i = kx + 1, n2
 
1236
    b(i+n1-n2) = '0'
 
1237
  enddo
 
1238
else
 
1239
  nx = - ix
 
1240
  b(n1-n2-1) = '0'
 
1241
  b(n1-n2) = '.'
 
1242
 
 
1243
  do i = 1, nx - 1
 
1244
    b(i+n1-n2) = '0'
 
1245
  enddo
 
1246
 
 
1247
  b(n1-n2+nx) = c(19)
 
1248
  kx = min (n - 20, n2 - nx)
 
1249
 
 
1250
  do i = 1, kx
 
1251
    b(i+n1-n2+nx) = c(i+20)
 
1252
  enddo
 
1253
 
 
1254
  do i = kx + 1, n2 - nx
 
1255
    b(i+n1-n2+nx) = '0'
 
1256
  enddo
 
1257
endif
 
1258
 
 
1259
200 continue
 
1260
 
 
1261
return
 
1262
end subroutine
 
1263
 
 
1264
  subroutine mpdotd (n, isa, a, isb, db, c)
 
1265
!   This routine computes the dot product of the MP vector A with the DP
 
1266
!   vector DB, returning the MP result in C.  This routine is used in the
 
1267
!   author's customized PSLQ routine, resulting in substantial speedup.
 
1268
!   The length of both the A and DB vectors is N, and ISA and ISB are the 
 
1269
!   skip distances between successive elements of A and DB, measured in 
 
1270
!   MP words and DP words, respectively.  The DP values in DB must be
 
1271
!   whole numbers, so for example they cannot be larger than 2^53.
 
1272
 
 
1273
      integer n, isa, isb
 
1274
      double precision db(isb*n)
 
1275
      type (mp_real) a(isa*n), c
 
1276
      integer mpnw
 
1277
      mpnw = mpnwx
 
1278
      call mpdotdx (n, isa * (mpwds + 4), a(1)%mpr, isb, db, c%mpr, mpnw)
 
1279
  end subroutine
 
1280
 
 
1281
  subroutine mpxzc (a, b)
 
1282
 
 
1283
!  This converts the DC variable A to the MPC variable B.
 
1284
!  This routine is not intended to be called directly by the user.
 
1285
 
 
1286
    complex (kdb) a
 
1287
    double precision da
 
1288
    real b(mp24)
 
1289
    da = a
 
1290
    call mpdmc (da, 0, b)
 
1291
    da = aimag (a)
 
1292
    call mpdmc (da, 0, b(mp41))
 
1293
    return
 
1294
  end subroutine
 
1295
 
 
1296
  subroutine mpmzc (a, b)
 
1297
 
 
1298
!  This converts the MP real or MP integer variable A to the MPC variable B.
 
1299
!  This routine is not intended to be called directly by the user.
 
1300
 
 
1301
    real a(mp4), b(mp24)
 
1302
    integer mpnw
 
1303
    mpnw = mpnwx
 
1304
    call mpeq (a, b, mpnw) 
 
1305
    b(mp41) = 0.
 
1306
    b(mp4+2) = 0.
 
1307
    return
 
1308
  end subroutine
 
1309
 
 
1310
end module
 
1311
 
 
1312
 
 
1313
module mpintmod
 
1314
 
 
1315
!  This Fortran-90 module defines operator extensions involving the
 
1316
!  MP_INTEGER datatype.  For operations involving two MP data types,
 
1317
!  those whose first argument is MP_INTEGER are included here.
 
1318
!  Others are handled in other modules.
 
1319
 
 
1320
!  The subroutines and functions defined in this module are private
 
1321
!  and not intended to be called directly by the user.
 
1322
 
 
1323
use mpfunmod
 
1324
use mpdefmod
 
1325
private kdb, mp4, mp24, mp41
 
1326
parameter (kdb = kind (0.d0), mp4 = mpwds + 4, mp24 = 2 * mp4, mp41 = mp4 + 1)
 
1327
private &
 
1328
  mp_eqjj, mp_eqjq, mp_eqjz, mp_eqij, mp_eqji, &
 
1329
  mp_eqdj, mp_eqjd, mp_eqxj, mp_eqjx, mp_eqja, &
 
1330
  mp_addjj, mp_addjq, mp_addjz, mp_addij, mp_addji, &
 
1331
  mp_adddj, mp_addjd, mp_addxj, mp_addjx, &
 
1332
  mp_subjj, mp_subjq, mp_subjz, mp_subij, mp_subji, &
 
1333
  mp_subdj, mp_subjd, mp_subxj, mp_subjx, mp_negj, &
 
1334
  mp_muljj, mp_muljq, mp_muljz, mp_mulij, mp_mulji, &
 
1335
  mp_muldj, mp_muljd, mp_mulxj, mp_muljx, &
 
1336
  mp_divjj, mp_divjq, mp_divjz, mp_divij, mp_divji, &
 
1337
  mp_divdj, mp_divjd, mp_divxj, mp_divjx, &
 
1338
  mp_expjj, mp_expjq, mp_expij, mp_expji, mp_expdj, mp_expjd, &
 
1339
  mp_eqtjj, mp_eqtjq, mp_eqtjz, mp_eqtij, mp_eqtji, &
 
1340
  mp_eqtdj, mp_eqtjd, mp_eqtxj, mp_eqtjx, &
 
1341
  mp_netjj, mp_netjq, mp_netjz, mp_netij, mp_netji, &
 
1342
  mp_netdj, mp_netjd, mp_netxj, mp_netjx, &
 
1343
  mp_letjj, mp_letjq, mp_letij, mp_letji, mp_letdj, mp_letjd, &
 
1344
  mp_getjj, mp_getjq, mp_getij, mp_getji, mp_getdj, mp_getjd, &
 
1345
  mp_lttjj, mp_lttjq, mp_lttij, mp_lttji, mp_lttdj, mp_lttjd, &
 
1346
  mp_gttjj, mp_gttjq, mp_gttij, mp_gttji, mp_gttdj, mp_gttjd
 
1347
 
 
1348
!  MPI operator extension interface blocks.
 
1349
 
 
1350
interface assignment (=)
 
1351
  module procedure mp_eqjj
 
1352
  module procedure mp_eqjq
 
1353
  module procedure mp_eqjz
 
1354
  module procedure mp_eqij
 
1355
  module procedure mp_eqji
 
1356
  module procedure mp_eqdj
 
1357
  module procedure mp_eqjd
 
1358
  module procedure mp_eqxj
 
1359
  module procedure mp_eqjx
 
1360
 
 
1361
  module procedure mp_eqja
 
1362
end interface
 
1363
 
 
1364
interface operator (+)
 
1365
  module procedure mp_addjj
 
1366
  module procedure mp_addjq
 
1367
  module procedure mp_addjz
 
1368
  module procedure mp_addij
 
1369
  module procedure mp_addji
 
1370
  module procedure mp_adddj
 
1371
  module procedure mp_addjd
 
1372
  module procedure mp_addxj
 
1373
  module procedure mp_addjx
 
1374
end interface
 
1375
 
 
1376
interface operator (-)
 
1377
  module procedure mp_subjj
 
1378
  module procedure mp_subjq
 
1379
  module procedure mp_subjz
 
1380
  module procedure mp_subij
 
1381
  module procedure mp_subji
 
1382
  module procedure mp_subdj
 
1383
  module procedure mp_subjd
 
1384
  module procedure mp_subxj
 
1385
  module procedure mp_subjx
 
1386
 
 
1387
  module procedure mp_negj
 
1388
end interface
 
1389
 
 
1390
interface operator (*)
 
1391
  module procedure mp_muljj
 
1392
  module procedure mp_muljq
 
1393
  module procedure mp_muljz
 
1394
  module procedure mp_mulij
 
1395
  module procedure mp_mulji
 
1396
  module procedure mp_muldj
 
1397
  module procedure mp_muljd
 
1398
  module procedure mp_mulxj
 
1399
  module procedure mp_muljx
 
1400
end interface
 
1401
 
 
1402
interface operator (/)
 
1403
  module procedure mp_divjj
 
1404
  module procedure mp_divjq
 
1405
  module procedure mp_divjz
 
1406
  module procedure mp_divij
 
1407
  module procedure mp_divji
 
1408
  module procedure mp_divdj
 
1409
  module procedure mp_divjd
 
1410
  module procedure mp_divxj
 
1411
  module procedure mp_divjx
 
1412
end interface
 
1413
 
 
1414
interface operator (**)
 
1415
  module procedure mp_expjj
 
1416
  module procedure mp_expjq
 
1417
  module procedure mp_expij
 
1418
  module procedure mp_expji
 
1419
  module procedure mp_expdj
 
1420
  module procedure mp_expjd
 
1421
end interface
 
1422
 
 
1423
interface operator (.eq.)
 
1424
  module procedure mp_eqtjj
 
1425
  module procedure mp_eqtjq
 
1426
  module procedure mp_eqtjz
 
1427
  module procedure mp_eqtij
 
1428
  module procedure mp_eqtji
 
1429
  module procedure mp_eqtdj
 
1430
  module procedure mp_eqtjd
 
1431
  module procedure mp_eqtxj
 
1432
  module procedure mp_eqtjx
 
1433
end interface
 
1434
 
 
1435
interface operator (.ne.)
 
1436
  module procedure mp_netjj
 
1437
  module procedure mp_netjq
 
1438
  module procedure mp_netjz
 
1439
  module procedure mp_netij
 
1440
  module procedure mp_netji
 
1441
  module procedure mp_netdj
 
1442
  module procedure mp_netjd
 
1443
  module procedure mp_netxj
 
1444
  module procedure mp_netjx
 
1445
end interface
 
1446
 
 
1447
interface operator (.le.)
 
1448
  module procedure mp_letjj
 
1449
  module procedure mp_letjq
 
1450
  module procedure mp_letij
 
1451
  module procedure mp_letji
 
1452
  module procedure mp_letdj
 
1453
  module procedure mp_letjd
 
1454
end interface
 
1455
 
 
1456
interface operator (.ge.)
 
1457
  module procedure mp_getjj
 
1458
  module procedure mp_getjq
 
1459
  module procedure mp_getij
 
1460
  module procedure mp_getji
 
1461
  module procedure mp_getdj
 
1462
  module procedure mp_getjd
 
1463
end interface
 
1464
 
 
1465
interface operator (.lt.)
 
1466
  module procedure mp_lttjj
 
1467
  module procedure mp_lttjq
 
1468
  module procedure mp_lttij
 
1469
  module procedure mp_lttji
 
1470
  module procedure mp_lttdj
 
1471
  module procedure mp_lttjd
 
1472
end interface
 
1473
 
 
1474
interface operator (.gt.)
 
1475
  module procedure mp_gttjj
 
1476
  module procedure mp_gttjq
 
1477
  module procedure mp_gttij
 
1478
  module procedure mp_gttji
 
1479
  module procedure mp_gttdj
 
1480
  module procedure mp_gttjd
 
1481
end interface
 
1482
 
 
1483
contains
 
1484
 
 
1485
!  MPI assignment routines.
 
1486
 
 
1487
  subroutine mp_eqjj (ja, jb)
 
1488
    implicit real*8 (d), type (mp_integer) (j), &
 
1489
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1490
    intent (out):: ja
 
1491
    intent (in):: jb
 
1492
    integer mpnw
 
1493
    mpnw = mpnwx
 
1494
    call mpeq (jb%mpi, ja%mpi, mpnw) 
 
1495
    return
 
1496
  end subroutine
 
1497
 
 
1498
  subroutine mp_eqjq (ja, qb)
 
1499
    implicit real*8 (d), type (mp_integer) (j), &
 
1500
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1501
    intent (out):: ja
 
1502
    intent (in):: qb
 
1503
    type (mp_real) q1, q2
 
1504
    integer mpnw
 
1505
    mpnw = mpnwx
 
1506
    call mpeq (qb%mpr, q1%mpr, mpnw) 
 
1507
    call mpinfr (q1%mpr, ja%mpi, q2%mpr, mpnw) 
 
1508
    return
 
1509
  end subroutine
 
1510
 
 
1511
  subroutine mp_eqjz (ja, zb)
 
1512
    implicit real*8 (d), type (mp_integer) (j), &
 
1513
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1514
    intent (out):: ja
 
1515
    intent (in):: zb
 
1516
    type (mp_real) q1, q2
 
1517
    integer mpnw
 
1518
    mpnw = mpnwx
 
1519
    call mpeq (zb%mpc, q1%mpr, mpnw) 
 
1520
    call mpinfr (q1%mpr, ja%mpi, q2%mpr, mpnw) 
 
1521
    return
 
1522
  end subroutine
 
1523
 
 
1524
  subroutine mp_eqij (ia, jb)
 
1525
    implicit real*8 (d), type (mp_integer) (j), &
 
1526
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1527
    intent (out):: ia
 
1528
    intent (in):: jb
 
1529
    integer mpnw
 
1530
    mpnw = mpnwx
 
1531
    call mpmdc (jb%mpi, db, ib)
 
1532
    ia = db * 2.d0 ** ib
 
1533
    return
 
1534
  end subroutine
 
1535
 
 
1536
  subroutine mp_eqji (ja, ib)
 
1537
    implicit real*8 (d), type (mp_integer) (j), &
 
1538
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1539
    intent (out):: ja
 
1540
    intent (in):: ib
 
1541
    integer mpnw
 
1542
    mpnw = mpnwx
 
1543
    db = ib
 
1544
    call mpdmc (db, 0, ja%mpi)
 
1545
    return
 
1546
  end subroutine
 
1547
 
 
1548
  subroutine mp_eqdj (da, jb)
 
1549
    implicit real*8 (d), type (mp_integer) (j), &
 
1550
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1551
    intent (out):: da
 
1552
    intent (in):: jb
 
1553
    integer mpnw
 
1554
    mpnw = mpnwx
 
1555
    call mpmdc (jb%mpi, db, ib)
 
1556
    da = db * 2.d0 ** ib
 
1557
    return
 
1558
  end subroutine
 
1559
 
 
1560
  subroutine mp_eqjd (ja, db)
 
1561
    implicit real*8 (d), type (mp_integer) (j), &
 
1562
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1563
    intent (out):: ja
 
1564
    intent (in):: db
 
1565
    type (mp_real) q1, q2
 
1566
    integer mpnw
 
1567
    mpnw = mpnwx
 
1568
    call mpdmc (db, 0, q1%mpr)
 
1569
    call mpinfr (q1%mpr, ja%mpi, q2%mpr, mpnw) 
 
1570
    return
 
1571
  end subroutine
 
1572
 
 
1573
  subroutine mp_eqxj (xa, jb)
 
1574
    implicit real*8 (d), type (mp_integer) (j), &
 
1575
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1576
    intent (out):: xa
 
1577
    intent (in):: jb
 
1578
    integer mpnw
 
1579
    mpnw = mpnwx
 
1580
    call mpmdc (jb%mpi, db, ib)
 
1581
    xa = db * 2.d0 ** ib
 
1582
    return
 
1583
  end subroutine
 
1584
 
 
1585
  subroutine mp_eqjx (ja, xb)
 
1586
    implicit real*8 (d), type (mp_integer) (j), &
 
1587
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1588
    intent (out):: ja
 
1589
    intent (in):: xb
 
1590
    type (mp_real) q1, q2
 
1591
    integer mpnw
 
1592
    mpnw = mpnwx
 
1593
    db = xb
 
1594
    call mpdmc (db, 0, q1%mpr)
 
1595
    call mpinfr (q1%mpr, ja%mpi, q2%mpr, mpnw) 
 
1596
    return
 
1597
  end subroutine
 
1598
 
 
1599
  subroutine mp_eqja (ja, ab)
 
1600
    implicit real*8 (d), type (mp_integer) (j), &
 
1601
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1602
    character*(*), intent (in):: ab
 
1603
    intent (out):: ja
 
1604
    character*1 az(mpipl+100)
 
1605
    type (mp_real) q1, q2
 
1606
    integer mpnw
 
1607
    mpnw = mpnwx
 
1608
    l = len (ab)
 
1609
    do i = 1, l
 
1610
      az(i) = ab(i:i)
 
1611
    enddo
 
1612
    call mpdexc (az, l, q1%mpr, mpnw) 
 
1613
    call mpinfr (q1%mpr, ja%mpi, q2%mpr, mpnw) 
 
1614
    return
 
1615
  end subroutine
 
1616
 
 
1617
!  MPI add routines.
 
1618
 
 
1619
  function mp_addjj (ja, jb)
 
1620
    implicit real*8 (d), type (mp_integer) (j), &
 
1621
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1622
    type (mp_integer):: mp_addjj
 
1623
    intent (in):: ja, jb
 
1624
    type (mp_real) q1, q2
 
1625
    integer mpnw
 
1626
    mpnw = mpnwx
 
1627
    call mpadd (ja%mpi, jb%mpi, q1%mpr, mpnw) 
 
1628
    call mpinfr (q1%mpr, mp_addjj%mpi, q2%mpr, mpnw) 
 
1629
    return
 
1630
  end function
 
1631
 
 
1632
  function mp_addjq (ja, qb)
 
1633
    implicit real*8 (d), type (mp_integer) (j), &
 
1634
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1635
    type (mp_real):: mp_addjq
 
1636
    intent (in):: ja, qb
 
1637
    integer mpnw
 
1638
    mpnw = mpnwx
 
1639
    call mpadd (ja%mpi, qb%mpr, mp_addjq%mpr, mpnw) 
 
1640
    return
 
1641
  end function
 
1642
 
 
1643
  function mp_addjz (ja, zb)
 
1644
    implicit real*8 (d), type (mp_integer) (j), &
 
1645
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1646
    type (mp_complex):: mp_addjz
 
1647
    intent (in):: ja, zb
 
1648
    type (mp_complex) z1
 
1649
    integer mpnw
 
1650
    mpnw = mpnwx
 
1651
    call mpmzc (ja%mpi, z1%mpc)
 
1652
    call mpcadd (mp4, z1%mpc, zb%mpc, mp_addjz%mpc, mpnw) 
 
1653
    return
 
1654
  end function
 
1655
 
 
1656
  function mp_addij (ia, jb)
 
1657
    implicit real*8 (d), type (mp_integer) (j), &
 
1658
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1659
    type (mp_integer):: mp_addij
 
1660
    intent (in):: ia, jb
 
1661
    type (mp_real) q1, q2, q3
 
1662
    integer mpnw
 
1663
    mpnw = mpnwx
 
1664
    da = ia
 
1665
    call mpdmc (da, 0, q1%mpr)
 
1666
    call mpadd (q1%mpr, jb%mpi, q2%mpr, mpnw) 
 
1667
    call mpinfr (q2%mpr, mp_addij%mpi, q3%mpr, mpnw) 
 
1668
    return
 
1669
  end function
 
1670
 
 
1671
  function mp_addji (ja, ib)
 
1672
    implicit real*8 (d), type (mp_integer) (j), &
 
1673
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1674
    type (mp_integer):: mp_addji
 
1675
    intent (in):: ja, ib
 
1676
    type (mp_real) q1, q2, q3
 
1677
    integer mpnw
 
1678
    mpnw = mpnwx
 
1679
    db = ib
 
1680
    call mpdmc (db, 0, q1%mpr)
 
1681
    call mpadd (ja%mpi, q1%mpr, q2%mpr, mpnw) 
 
1682
    call mpinfr (q2%mpr, mp_addji%mpi, q3%mpr, mpnw) 
 
1683
    return
 
1684
  end function
 
1685
 
 
1686
  function mp_adddj (da, jb)
 
1687
    implicit real*8 (d), type (mp_integer) (j), &
 
1688
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1689
    type (mp_real):: mp_adddj
 
1690
    intent (in):: da, jb
 
1691
    type (mp_real) q1
 
1692
    integer mpnw
 
1693
    mpnw = mpnwx
 
1694
    call mpdmc (da, 0, q1%mpr)
 
1695
    call mpadd (q1%mpr, jb%mpi, mp_adddj%mpr, mpnw) 
 
1696
    return
 
1697
  end function
 
1698
 
 
1699
  function mp_addjd (ja, db)
 
1700
    implicit real*8 (d), type (mp_integer) (j), &
 
1701
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1702
    type (mp_real):: mp_addjd
 
1703
    intent (in):: ja, db
 
1704
    type (mp_real) q1
 
1705
    integer mpnw
 
1706
    mpnw = mpnwx
 
1707
    call mpdmc (db, 0, q1%mpr)
 
1708
    call mpadd (ja%mpi, q1%mpr, mp_addjd%mpr, mpnw) 
 
1709
    return
 
1710
  end function
 
1711
 
 
1712
  function mp_addxj (xa, jb)
 
1713
    implicit real*8 (d), type (mp_integer) (j), &
 
1714
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1715
    type (mp_complex):: mp_addxj
 
1716
    intent (in):: xa, jb
 
1717
    type (mp_complex) z1, z2
 
1718
    integer mpnw
 
1719
    mpnw = mpnwx
 
1720
    call mpxzc (xa, z1%mpc)
 
1721
    call mpmzc (jb%mpi, z2%mpc)
 
1722
    call mpcadd (mp4, z1%mpc, z2%mpc, mp_addxj%mpc, mpnw) 
 
1723
    return
 
1724
  end function
 
1725
 
 
1726
  function mp_addjx (ja, xb)
 
1727
    implicit real*8 (d), type (mp_integer) (j), &
 
1728
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1729
    type (mp_complex):: mp_addjx
 
1730
    intent (in):: ja, xb
 
1731
    type (mp_complex) z1, z2
 
1732
    integer mpnw
 
1733
    mpnw = mpnwx
 
1734
    call mpmzc (ja%mpi, z1%mpc)
 
1735
    call mpxzc (xb, z2%mpc)
 
1736
    call mpcadd (mp4, z1%mpc, z2%mpc, mp_addjx%mpc, mpnw) 
 
1737
    return
 
1738
  end function
 
1739
 
 
1740
!  MPI subtract routines.
 
1741
 
 
1742
  function mp_subjj (ja, jb)
 
1743
    implicit real*8 (d), type (mp_integer) (j), &
 
1744
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1745
    type (mp_integer):: mp_subjj
 
1746
    intent (in):: ja, jb
 
1747
    type (mp_real) q1, q2
 
1748
    integer mpnw
 
1749
    mpnw = mpnwx
 
1750
    call mpsub (ja%mpi, jb%mpi, q1%mpr, mpnw) 
 
1751
    call mpinfr (q1%mpr, mp_subjj%mpi, q2%mpr, mpnw) 
 
1752
    return
 
1753
  end function
 
1754
 
 
1755
  function mp_subjq (ja, qb)
 
1756
    implicit real*8 (d), type (mp_integer) (j), &
 
1757
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1758
    type (mp_real):: mp_subjq
 
1759
    intent (in):: ja, qb
 
1760
    integer mpnw
 
1761
    mpnw = mpnwx
 
1762
    call mpsub (ja%mpi, qb%mpr, mp_subjq%mpr, mpnw) 
 
1763
    return
 
1764
  end function
 
1765
 
 
1766
  function mp_subjz (ja, zb)
 
1767
    implicit real*8 (d), type (mp_integer) (j), &
 
1768
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1769
    type (mp_complex):: mp_subjz
 
1770
    intent (in):: ja, zb
 
1771
    type (mp_complex) z1
 
1772
    integer mpnw
 
1773
    mpnw = mpnwx
 
1774
    call mpmzc (ja%mpi, z1%mpc)
 
1775
    call mpcsub (mp4, z1%mpc, zb%mpc, mp_subjz%mpc, mpnw) 
 
1776
    return
 
1777
  end function
 
1778
 
 
1779
  function mp_subij (ia, jb)
 
1780
    implicit real*8 (d), type (mp_integer) (j), &
 
1781
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1782
    type (mp_integer):: mp_subij
 
1783
    intent (in):: ia, jb
 
1784
    type (mp_real) q1, q2, q3
 
1785
    integer mpnw
 
1786
    mpnw = mpnwx
 
1787
    da = ia
 
1788
    call mpdmc (da, 0, q1%mpr)
 
1789
    call mpsub (q1%mpr, jb%mpi, q2%mpr, mpnw) 
 
1790
    call mpinfr (q2%mpr, mp_subij%mpi, q3%mpr, mpnw) 
 
1791
    return
 
1792
  end function
 
1793
 
 
1794
  function mp_subji (ja, ib)
 
1795
    implicit real*8 (d), type (mp_integer) (j), &
 
1796
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1797
    type (mp_integer):: mp_subji
 
1798
    intent (in):: ja, ib
 
1799
    type (mp_real) q1, q2, q3
 
1800
    integer mpnw
 
1801
    mpnw = mpnwx
 
1802
    db = ib
 
1803
    call mpdmc (db, 0, q1%mpr)
 
1804
    call mpsub (ja%mpi, q1%mpr, q2%mpr, mpnw) 
 
1805
    call mpinfr (q2%mpr, mp_subji%mpi, q3%mpr, mpnw) 
 
1806
    return
 
1807
  end function
 
1808
 
 
1809
  function mp_subdj (da, jb)
 
1810
    implicit real*8 (d), type (mp_integer) (j), &
 
1811
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1812
    type (mp_real):: mp_subdj
 
1813
    intent (in):: da, jb
 
1814
    type (mp_real) q1
 
1815
    integer mpnw
 
1816
    mpnw = mpnwx
 
1817
    call mpdmc (da, 0, q1%mpr)
 
1818
    call mpsub (q1%mpr, jb%mpi, mp_subdj%mpr, mpnw) 
 
1819
    return
 
1820
  end function
 
1821
 
 
1822
  function mp_subjd (ja, db)
 
1823
    implicit real*8 (d), type (mp_integer) (j), &
 
1824
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1825
    type (mp_real):: mp_subjd
 
1826
    intent (in):: ja, db
 
1827
    type (mp_real) q1
 
1828
    integer mpnw
 
1829
    mpnw = mpnwx
 
1830
    call mpdmc (db, 0, q1%mpr)
 
1831
    call mpsub (ja%mpi, q1%mpr, mp_subjd%mpr, mpnw) 
 
1832
    return
 
1833
  end function
 
1834
 
 
1835
  function mp_subxj (xa, jb)
 
1836
    implicit real*8 (d), type (mp_integer) (j), &
 
1837
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1838
    type (mp_complex):: mp_subxj
 
1839
    intent (in):: xa, jb
 
1840
    type (mp_complex) z1, z2
 
1841
    integer mpnw
 
1842
    mpnw = mpnwx
 
1843
    call mpxzc (xa, z1%mpc)
 
1844
    call mpmzc (jb%mpi, z2%mpc)
 
1845
    call mpcsub (mp4, z1%mpc, z2%mpc, mp_subxj%mpc, mpnw) 
 
1846
    return
 
1847
  end function
 
1848
 
 
1849
  function mp_subjx (ja, xb)
 
1850
    implicit real*8 (d), type (mp_integer) (j), &
 
1851
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1852
    type (mp_complex):: mp_subjx
 
1853
    intent (in):: ja, xb
 
1854
    type (mp_complex) z1, z2
 
1855
    integer mpnw
 
1856
    mpnw = mpnwx
 
1857
    call mpmzc (ja%mpi, z1%mpc)
 
1858
    call mpxzc (xb, z2%mpc)
 
1859
    call mpcsub (mp4, z1%mpc, z2%mpc, mp_subjx%mpc, mpnw) 
 
1860
    return
 
1861
  end function
 
1862
 
 
1863
!  MPI negation routine.
 
1864
 
 
1865
  function mp_negj (ja)
 
1866
    implicit real*8 (d), type (mp_integer) (j), &
 
1867
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1868
    type (mp_integer):: mp_negj
 
1869
    intent (in):: ja
 
1870
    integer mpnw
 
1871
    mpnw = mpnwx
 
1872
    call mpeq (ja%mpi, mp_negj%mpi, mpnw) 
 
1873
    mp_negj%mpi(1) = - ja%mpi(1)
 
1874
    return
 
1875
  end function
 
1876
 
 
1877
!  MPI multiply routines.
 
1878
 
 
1879
  function mp_muljj (ja, jb)
 
1880
    implicit real*8 (d), type (mp_integer) (j), &
 
1881
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1882
    type (mp_integer):: mp_muljj
 
1883
    intent (in):: ja, jb
 
1884
    type (mp_real) q1, q2
 
1885
    integer mpnw
 
1886
    mpnw = mpnwx
 
1887
    call mpmul (ja%mpi, jb%mpi, q1%mpr, mpnw) 
 
1888
    call mpinfr (q1%mpr, mp_muljj%mpi, q2%mpr, mpnw) 
 
1889
    return
 
1890
  end function
 
1891
 
 
1892
  function mp_muljq (ja, qb)
 
1893
    implicit real*8 (d), type (mp_integer) (j), &
 
1894
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1895
    type (mp_real):: mp_muljq
 
1896
    intent (in):: ja, qb
 
1897
    integer mpnw
 
1898
    mpnw = mpnwx
 
1899
    call mpmul (ja%mpi, qb%mpr, mp_muljq%mpr, mpnw) 
 
1900
    return
 
1901
  end function
 
1902
 
 
1903
  function mp_muljz (ja, zb)
 
1904
    implicit real*8 (d), type (mp_integer) (j), &
 
1905
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1906
    type (mp_complex):: mp_muljz
 
1907
    intent (in):: ja, zb
 
1908
    type (mp_complex) z1
 
1909
    integer mpnw
 
1910
    mpnw = mpnwx
 
1911
    call mpmzc (ja%mpi, z1%mpc)
 
1912
    call mpcmul (mp4, z1%mpc, zb%mpc, mp_muljz%mpc, mpnw) 
 
1913
    return
 
1914
  end function
 
1915
 
 
1916
  function mp_mulij (ia, jb)
 
1917
    implicit real*8 (d), type (mp_integer) (j), &
 
1918
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1919
    type (mp_integer):: mp_mulij
 
1920
    intent (in):: ia, jb
 
1921
    type (mp_real) q1, q2
 
1922
    integer mpnw
 
1923
    mpnw = mpnwx
 
1924
    da = ia
 
1925
    call mpmuld (jb%mpi, da, 0, q1%mpr, mpnw) 
 
1926
    call mpinfr (q1%mpr, mp_mulij%mpi, q2%mpr, mpnw) 
 
1927
    return
 
1928
  end function
 
1929
 
 
1930
  function mp_mulji (ja, ib)
 
1931
    implicit real*8 (d), type (mp_integer) (j), &
 
1932
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1933
    type (mp_integer):: mp_mulji
 
1934
    intent (in):: ja, ib
 
1935
    type (mp_real) q1, q2
 
1936
    integer mpnw
 
1937
    mpnw = mpnwx
 
1938
    db = ib
 
1939
    call mpmuld (ja%mpi, db, 0, q1%mpr, mpnw) 
 
1940
    call mpinfr (q1%mpr, mp_mulji%mpi, q2%mpr, mpnw) 
 
1941
    return
 
1942
  end function
 
1943
 
 
1944
  function mp_muldj (da, jb)
 
1945
    implicit real*8 (d), type (mp_integer) (j), &
 
1946
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1947
    type (mp_real):: mp_muldj
 
1948
    intent (in):: da, jb
 
1949
    integer mpnw
 
1950
    mpnw = mpnwx
 
1951
    call mpmuld (jb%mpi, da, 0, mp_muldj%mpr, mpnw) 
 
1952
    return
 
1953
  end function
 
1954
 
 
1955
  function mp_muljd (ja, db)
 
1956
    implicit real*8 (d), type (mp_integer) (j), &
 
1957
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1958
    type (mp_real):: mp_muljd
 
1959
    intent (in):: ja, db
 
1960
    integer mpnw
 
1961
    mpnw = mpnwx
 
1962
    call mpmuld (ja%mpi, db, 0, mp_muljd%mpr, mpnw) 
 
1963
    return
 
1964
  end function
 
1965
 
 
1966
  function mp_mulxj (xa, jb)
 
1967
    implicit real*8 (d), type (mp_integer) (j), &
 
1968
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1969
    type (mp_complex):: mp_mulxj
 
1970
    intent (in):: xa, jb
 
1971
    type (mp_complex) z1, z2
 
1972
    integer mpnw
 
1973
    mpnw = mpnwx
 
1974
    call mpxzc (xa, z1%mpc)
 
1975
    call mpmzc (jb%mpi, z2%mpc)
 
1976
    call mpcmul (mp4, z1%mpc, z2%mpc, mp_mulxj%mpc, mpnw) 
 
1977
    return
 
1978
  end function
 
1979
 
 
1980
  function mp_muljx (ja, xb)
 
1981
    implicit real*8 (d), type (mp_integer) (j), &
 
1982
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1983
    type (mp_complex):: mp_muljx
 
1984
    intent (in):: ja, xb
 
1985
    type (mp_complex) z1, z2
 
1986
    integer mpnw
 
1987
    mpnw = mpnwx
 
1988
    call mpmzc (ja%mpi, z1%mpc)
 
1989
    call mpxzc (xb, z2%mpc)
 
1990
    call mpcmul (mp4, z1%mpc, z2%mpc, mp_muljx%mpc, mpnw) 
 
1991
    return
 
1992
  end function
 
1993
 
 
1994
!  MPI divide routines.
 
1995
 
 
1996
  function mp_divjj (ja, jb)
 
1997
    implicit real*8 (d), type (mp_integer) (j), &
 
1998
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
1999
    type (mp_integer):: mp_divjj
 
2000
    intent (in):: ja, jb
 
2001
    type (mp_real) q1, q2
 
2002
    integer mpnw
 
2003
    mpnw = mpnwx
 
2004
    call mpdiv (ja%mpi, jb%mpi, q1%mpr, mpnw) 
 
2005
    call mpinfr (q1%mpr, mp_divjj%mpi, q2%mpr, mpnw) 
 
2006
    return
 
2007
  end function
 
2008
 
 
2009
  function mp_divjq (ja, qb)
 
2010
    implicit real*8 (d), type (mp_integer) (j), &
 
2011
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2012
    type (mp_real):: mp_divjq
 
2013
    intent (in):: ja, qb
 
2014
    integer mpnw
 
2015
    mpnw = mpnwx
 
2016
    call mpdiv (ja%mpi, qb%mpr, mp_divjq%mpr, mpnw) 
 
2017
    return
 
2018
  end function
 
2019
 
 
2020
  function mp_divjz (ja, zb)
 
2021
    implicit real*8 (d), type (mp_integer) (j), &
 
2022
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2023
    type (mp_complex):: mp_divjz
 
2024
    intent (in):: ja, zb
 
2025
    type (mp_complex) z1
 
2026
    integer mpnw
 
2027
    mpnw = mpnwx
 
2028
    call mpmzc (ja%mpi, z1%mpc)
 
2029
    call mpcdiv (mp4, z1%mpc, zb%mpc, mp_divjz%mpc, mpnw) 
 
2030
    return
 
2031
  end function
 
2032
 
 
2033
  function mp_divij (ia, jb)
 
2034
    implicit real*8 (d), type (mp_integer) (j), &
 
2035
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2036
    type (mp_integer):: mp_divij
 
2037
    intent (in):: ia, jb
 
2038
    type (mp_real) q1, q2, q3
 
2039
    integer mpnw
 
2040
    mpnw = mpnwx
 
2041
    da = ia
 
2042
    call mpdmc (da, 0, q1%mpr)
 
2043
    call mpdiv (q1%mpr, jb%mpi, q2%mpr, mpnw) 
 
2044
    call mpinfr (q2%mpr, mp_divij%mpi, q3%mpr, mpnw) 
 
2045
    return
 
2046
  end function
 
2047
 
 
2048
  function mp_divji (ja, ib)
 
2049
    implicit real*8 (d), type (mp_integer) (j), &
 
2050
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2051
    type (mp_integer):: mp_divji
 
2052
    intent (in):: ja, ib
 
2053
    type (mp_real) q1, q2
 
2054
    integer mpnw
 
2055
    mpnw = mpnwx
 
2056
    db = ib
 
2057
    call mpdivd (ja%mpi, db, 0, q1%mpr, mpnw) 
 
2058
    call mpinfr (q1%mpr, mp_divji%mpi, q2%mpr, mpnw) 
 
2059
    return
 
2060
  end function
 
2061
 
 
2062
  function mp_divdj (da, jb)
 
2063
    implicit real*8 (d), type (mp_integer) (j), &
 
2064
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2065
    type (mp_real):: mp_divdj
 
2066
    intent (in):: da, jb
 
2067
    type (mp_real) q1
 
2068
    integer mpnw
 
2069
    mpnw = mpnwx
 
2070
    call mpdmc (da, 0, q1%mpr)
 
2071
    call mpdiv (q1%mpr, jb%mpi, mp_divdj%mpr, mpnw) 
 
2072
    return
 
2073
  end function
 
2074
 
 
2075
  function mp_divjd (ja, db)
 
2076
    implicit real*8 (d), type (mp_integer) (j), &
 
2077
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2078
    type (mp_real):: mp_divjd
 
2079
    intent (in):: ja, db
 
2080
    integer mpnw
 
2081
    mpnw = mpnwx
 
2082
    call mpdivd (ja%mpi, db, 0, mp_divjd%mpr, mpnw) 
 
2083
    return
 
2084
  end function
 
2085
 
 
2086
  function mp_divxj (xa, jb)
 
2087
    implicit real*8 (d), type (mp_integer) (j), &
 
2088
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2089
    type (mp_complex):: mp_divxj
 
2090
    intent (in):: xa, jb
 
2091
    type (mp_complex) z1, z2
 
2092
    integer mpnw
 
2093
    mpnw = mpnwx
 
2094
    call mpxzc (xa, z1%mpc)
 
2095
    call mpmzc (jb%mpi, z2%mpc)
 
2096
    call mpcdiv (mp4, z1%mpc, z2%mpc, mp_divxj%mpc, mpnw) 
 
2097
    return
 
2098
  end function
 
2099
 
 
2100
  function mp_divjx (ja, xb)
 
2101
    implicit real*8 (d), type (mp_integer) (j), &
 
2102
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2103
    type (mp_complex):: mp_divjx
 
2104
    intent (in):: ja, xb
 
2105
    type (mp_complex) z1, z2
 
2106
    integer mpnw
 
2107
    mpnw = mpnwx
 
2108
    call mpmzc (ja%mpi, z1%mpc)
 
2109
    call mpxzc (xb, z2%mpc)
 
2110
    call mpcdiv (mp4, z1%mpc, z2%mpc, mp_divjx%mpc, mpnw) 
 
2111
    return
 
2112
  end function
 
2113
 
 
2114
!  MPI exponentiation routines.
 
2115
 
 
2116
  function mp_expjj (ja, jb)
 
2117
    implicit real*8 (d), type (mp_integer) (j), &
 
2118
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2119
    type (mp_integer):: mp_expjj
 
2120
    intent (in):: ja, jb
 
2121
    type (mp_real) q1, q2
 
2122
    integer mpnw
 
2123
    mpnw = mpnwx
 
2124
    call mplog (ja%mpi, mpl02%mpr, q1%mpr, mpnw) 
 
2125
    call mpmul (q1%mpr, jb%mpi, q2%mpr, mpnw) 
 
2126
    call mpexp (q2%mpr, mpl02%mpr, q1%mpr, mpnw) 
 
2127
    call mpnint (q1%mpr, mp_expjj%mpi, mpnw) 
 
2128
    return
 
2129
  end function
 
2130
 
 
2131
  function mp_expjq (ja, qb)
 
2132
    implicit real*8 (d), type (mp_integer) (j), &
 
2133
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2134
    type (mp_real):: mp_expjq
 
2135
    intent (in):: ja, qb
 
2136
    type (mp_real) q1, q2
 
2137
    integer mpnw
 
2138
    mpnw = mpnwx
 
2139
    call mplog (ja%mpi, mpl02%mpr, q1%mpr, mpnw) 
 
2140
    call mpmul (q1%mpr, qb%mpr, q2%mpr, mpnw) 
 
2141
    call mpexp (q2%mpr, mpl02%mpr, mp_expjq%mpr, mpnw) 
 
2142
    return
 
2143
  end function
 
2144
 
 
2145
  function mp_expij (ia, jb)
 
2146
    implicit real*8 (d), type (mp_integer) (j), &
 
2147
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2148
    type (mp_integer):: mp_expij
 
2149
    intent (in):: ia, jb
 
2150
    type (mp_real) q1, q2, q3
 
2151
    integer mpnw
 
2152
    mpnw = mpnwx
 
2153
    da = ia
 
2154
    call mpdmc (da, 0, q1%mpr)
 
2155
    call mplog (q1%mpr, mpl02%mpr, q2%mpr, mpnw) 
 
2156
    call mpmul (q2%mpr, jb%mpi, q3%mpr, mpnw) 
 
2157
    call mpexp (q3%mpr, mpl02%mpr, q1%mpr, mpnw) 
 
2158
    call mpnint (q1%mpr, mp_expij%mpi, mpnw) 
 
2159
    return
 
2160
  end function
 
2161
 
 
2162
  function mp_expji (ja, ib)
 
2163
    implicit real*8 (d), type (mp_integer) (j), &
 
2164
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2165
    type (mp_integer):: mp_expji
 
2166
    intent (in):: ja, ib
 
2167
    type (mp_real) q1
 
2168
    integer mpnw
 
2169
    mpnw = mpnwx
 
2170
    call mpnpwr (ja%mpi, ib, q1%mpr, mpnw) 
 
2171
    call mpnint (q1%mpr, mp_expji%mpi, mpnw) 
 
2172
    return
 
2173
  end function
 
2174
 
 
2175
  function mp_expdj (da, jb)
 
2176
    implicit real*8 (d), type (mp_integer) (j), &
 
2177
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2178
    type (mp_real):: mp_expdj
 
2179
    intent (in):: da, jb
 
2180
    type (mp_real) q1, q2, q3
 
2181
    integer mpnw
 
2182
    mpnw = mpnwx
 
2183
    call mpdmc (da, 0, q1%mpr)
 
2184
    call mplog (q1%mpr, mpl02%mpr, q2%mpr, mpnw) 
 
2185
    call mpmul (q2%mpr, jb%mpi, q3%mpr, mpnw) 
 
2186
    call mpexp (q3%mpr, mpl02%mpr, mp_expdj%mpr, mpnw) 
 
2187
    return
 
2188
    end function
 
2189
 
 
2190
  function mp_expjd (ja, db)
 
2191
    implicit real*8 (d), type (mp_integer) (j), &
 
2192
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2193
    type (mp_real):: mp_expjd
 
2194
    intent (in):: ja, db
 
2195
    type (mp_real) q1, q2
 
2196
    integer mpnw
 
2197
    mpnw = mpnwx
 
2198
    call mplog (ja%mpi, mpl02%mpr, q1%mpr, mpnw) 
 
2199
    call mpmuld (q1%mpr, db, 0, q2%mpr, mpnw) 
 
2200
    call mpexp (q2%mpr, mpl02%mpr, mp_expjd%mpr, mpnw) 
 
2201
    return
 
2202
  end function
 
2203
 
 
2204
!  MPI .EQ. routines.
 
2205
 
 
2206
  function mp_eqtjj (ja, jb)
 
2207
    implicit real*8 (d), type (mp_integer) (j), &
 
2208
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2209
    logical mp_eqtjj
 
2210
    intent (in):: ja, jb
 
2211
    integer mpnw
 
2212
    mpnw = mpnwx
 
2213
    call mpcpr (ja%mpi, jb%mpi, ic, mpnw) 
 
2214
    if (ic .eq. 0) then
 
2215
      mp_eqtjj = .true.
 
2216
    else
 
2217
      mp_eqtjj = .false.
 
2218
    endif
 
2219
    return
 
2220
  end function
 
2221
 
 
2222
  function mp_eqtjq (ja, qb)
 
2223
    implicit real*8 (d), type (mp_integer) (j), &
 
2224
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2225
    logical mp_eqtjq
 
2226
    intent (in):: ja, qb
 
2227
    integer mpnw
 
2228
    mpnw = mpnwx
 
2229
    call mpcpr (ja%mpi, qb%mpr, ic, mpnw) 
 
2230
    if (ic .eq. 0) then
 
2231
      mp_eqtjq = .true.
 
2232
    else
 
2233
      mp_eqtjq = .false.
 
2234
    endif
 
2235
    return
 
2236
  end function
 
2237
 
 
2238
  function mp_eqtjz (ja, zb)
 
2239
    implicit real*8 (d), type (mp_integer) (j), &
 
2240
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2241
    logical mp_eqtjz
 
2242
    intent (in):: ja, zb
 
2243
    type (mp_complex) z1
 
2244
    integer mpnw
 
2245
    mpnw = mpnwx
 
2246
    call mpmzc (ja%mpi, z1%mpc)
 
2247
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
2248
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
2249
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
2250
      mp_eqtjz = .true.
 
2251
    else
 
2252
      mp_eqtjz = .false.
 
2253
    endif
 
2254
    return
 
2255
  end function
 
2256
 
 
2257
  function mp_eqtij (ia, jb)
 
2258
    implicit real*8 (d), type (mp_integer) (j), &
 
2259
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2260
    logical mp_eqtij
 
2261
    intent (in):: ia, jb
 
2262
    type (mp_real) q1
 
2263
    integer mpnw
 
2264
    mpnw = mpnwx
 
2265
    da = ia
 
2266
    call mpdmc (da, 0, q1%mpr)
 
2267
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2268
    if (ic .eq. 0) then
 
2269
      mp_eqtij = .true.
 
2270
    else
 
2271
      mp_eqtij = .false.
 
2272
    endif
 
2273
    return
 
2274
  end function
 
2275
 
 
2276
  function mp_eqtji (ja, ib)
 
2277
    implicit real*8 (d), type (mp_integer) (j), &
 
2278
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2279
    logical mp_eqtji
 
2280
    intent (in):: ja, ib
 
2281
    type (mp_real) q1
 
2282
    integer mpnw
 
2283
    mpnw = mpnwx
 
2284
    db = ib
 
2285
    call mpdmc (db, 0, q1%mpr)
 
2286
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2287
    if (ic .eq. 0) then
 
2288
      mp_eqtji = .true.
 
2289
    else
 
2290
      mp_eqtji = .false.
 
2291
    endif
 
2292
    return
 
2293
  end function
 
2294
 
 
2295
  function mp_eqtdj (da, jb)
 
2296
    implicit real*8 (d), type (mp_integer) (j), &
 
2297
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2298
    logical mp_eqtdj
 
2299
    intent (in):: da, jb
 
2300
    type (mp_real) q1
 
2301
    integer mpnw
 
2302
    mpnw = mpnwx
 
2303
    call mpdmc (da, 0, q1%mpr)
 
2304
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2305
    if (ic .eq. 0) then
 
2306
      mp_eqtdj = .true.
 
2307
    else
 
2308
      mp_eqtdj = .false.
 
2309
    endif
 
2310
    return
 
2311
  end function
 
2312
 
 
2313
  function mp_eqtjd (ja, db)
 
2314
    implicit real*8 (d), type (mp_integer) (j), &
 
2315
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2316
    logical mp_eqtjd
 
2317
    intent (in):: ja, db
 
2318
    type (mp_real) q1
 
2319
    integer mpnw
 
2320
    mpnw = mpnwx
 
2321
    call mpdmc (db, 0, q1%mpr)
 
2322
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2323
    if (ic .eq. 0) then
 
2324
      mp_eqtjd = .true.
 
2325
    else
 
2326
      mp_eqtjd = .false.
 
2327
    endif
 
2328
    return
 
2329
  end function
 
2330
 
 
2331
  function mp_eqtxj (xa, jb)
 
2332
    implicit real*8 (d), type (mp_integer) (j), &
 
2333
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2334
    logical mp_eqtxj
 
2335
    intent (in):: xa, jb
 
2336
    type (mp_complex) z1, z2
 
2337
    integer mpnw
 
2338
    mpnw = mpnwx
 
2339
    call mpxzc (xa, z1%mpc)
 
2340
    call mpmzc (jb%mpi, z2%mpc)
 
2341
    call mpcpr (z1%mpc, z2%mpc, ic1, mpnw) 
 
2342
    call mpcpr (z1%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
2343
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
2344
      mp_eqtxj = .true.
 
2345
    else
 
2346
      mp_eqtxj = .false.
 
2347
    endif
 
2348
    return
 
2349
  end function
 
2350
 
 
2351
  function mp_eqtjx (ja, xb)
 
2352
    implicit real*8 (d), type (mp_integer) (j), &
 
2353
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2354
    logical mp_eqtjx
 
2355
    intent (in):: ja, xb
 
2356
    type (mp_complex) z1, z2
 
2357
    integer mpnw
 
2358
    mpnw = mpnwx
 
2359
    call mpmzc (ja%mpi, z1%mpc)
 
2360
    call mpxzc (xb, z2%mpc)
 
2361
    call mpcpr (z1%mpc, z2%mpc, ic1, mpnw) 
 
2362
    call mpcpr (z1%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
2363
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
2364
      mp_eqtjx = .true.
 
2365
    else
 
2366
      mp_eqtjx = .false.
 
2367
    endif
 
2368
    return
 
2369
  end function
 
2370
 
 
2371
!  MPI .NE. routines.
 
2372
 
 
2373
  function mp_netjj (ja, jb)
 
2374
    implicit real*8 (d), type (mp_integer) (j), &
 
2375
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2376
    logical mp_netjj
 
2377
    intent (in):: ja, jb
 
2378
    integer mpnw
 
2379
    mpnw = mpnwx
 
2380
    call mpcpr (ja%mpi, jb%mpi, ic, mpnw) 
 
2381
    if (ic .ne. 0) then
 
2382
      mp_netjj = .true.
 
2383
    else
 
2384
      mp_netjj = .false.
 
2385
    endif
 
2386
    return
 
2387
  end function
 
2388
 
 
2389
  function mp_netjq (ja, qb)
 
2390
    implicit real*8 (d), type (mp_integer) (j), &
 
2391
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2392
    logical mp_netjq
 
2393
    intent (in):: ja, qb
 
2394
    integer mpnw
 
2395
    mpnw = mpnwx
 
2396
    call mpcpr (ja%mpi, qb%mpr, ic, mpnw) 
 
2397
    if (ic .ne. 0) then
 
2398
      mp_netjq = .true.
 
2399
    else
 
2400
      mp_netjq = .false.
 
2401
    endif
 
2402
    return
 
2403
  end function
 
2404
 
 
2405
  function mp_netjz (ja, zb)
 
2406
    implicit real*8 (d), type (mp_integer) (j), &
 
2407
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2408
    logical mp_netjz
 
2409
    intent (in):: ja, zb
 
2410
    type (mp_complex) z1
 
2411
    integer mpnw
 
2412
    mpnw = mpnwx
 
2413
    call mpmzc (ja%mpi, z1%mpc)
 
2414
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
2415
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
2416
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
2417
      mp_netjz = .true.
 
2418
    else
 
2419
      mp_netjz = .false.
 
2420
    endif
 
2421
    return
 
2422
  end function
 
2423
 
 
2424
  function mp_netij (ia, jb)
 
2425
    implicit real*8 (d), type (mp_integer) (j), &
 
2426
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2427
    logical mp_netij
 
2428
    intent (in):: ia, jb
 
2429
    type (mp_real) q1
 
2430
    integer mpnw
 
2431
    mpnw = mpnwx
 
2432
    da = ia
 
2433
    call mpdmc (da, 0, q1%mpr)
 
2434
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2435
    if (ic .ne. 0) then
 
2436
      mp_netij = .true.
 
2437
    else
 
2438
      mp_netij = .false.
 
2439
    endif
 
2440
    return
 
2441
  end function
 
2442
 
 
2443
  function mp_netji (ja, ib)
 
2444
    implicit real*8 (d), type (mp_integer) (j), &
 
2445
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2446
    logical mp_netji
 
2447
    intent (in):: ja, ib
 
2448
    type (mp_real) q1
 
2449
    integer mpnw
 
2450
    mpnw = mpnwx
 
2451
    db = ib
 
2452
    call mpdmc (db, 0, q1%mpr)
 
2453
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2454
    if (ic .ne. 0) then
 
2455
      mp_netji = .true.
 
2456
    else
 
2457
      mp_netji = .false.
 
2458
    endif
 
2459
    return
 
2460
  end function
 
2461
 
 
2462
  function mp_netdj (da, jb)
 
2463
    implicit real*8 (d), type (mp_integer) (j), &
 
2464
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2465
    logical mp_netdj
 
2466
    intent (in):: da, jb
 
2467
    type (mp_real) q1
 
2468
    integer mpnw
 
2469
    mpnw = mpnwx
 
2470
    call mpdmc (da, 0, q1%mpr)
 
2471
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2472
    if (ic .ne. 0) then
 
2473
      mp_netdj = .true.
 
2474
    else
 
2475
      mp_netdj = .false.
 
2476
    endif
 
2477
    return
 
2478
  end function
 
2479
 
 
2480
  function mp_netjd (ja, db)
 
2481
    implicit real*8 (d), type (mp_integer) (j), &
 
2482
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2483
    logical mp_netjd
 
2484
    intent (in):: ja, db
 
2485
    type (mp_real) q1
 
2486
    integer mpnw
 
2487
    mpnw = mpnwx
 
2488
    call mpdmc (db, 0, q1%mpr)
 
2489
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2490
    if (ic .ne. 0) then
 
2491
      mp_netjd = .true.
 
2492
    else
 
2493
      mp_netjd = .false.
 
2494
    endif
 
2495
    return
 
2496
  end function
 
2497
 
 
2498
  function mp_netxj (xa, jb)
 
2499
    implicit real*8 (d), type (mp_integer) (j), &
 
2500
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2501
    logical mp_netxj
 
2502
    intent (in):: xa, jb
 
2503
    type (mp_complex) z1, z2
 
2504
    integer mpnw
 
2505
    mpnw = mpnwx
 
2506
    call mpxzc (xa, z1%mpc)
 
2507
    call mpmzc (jb%mpi, z2%mpc)
 
2508
    call mpcpr (z1%mpc, z2%mpc, ic1, mpnw) 
 
2509
    call mpcpr (z1%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
2510
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
2511
      mp_netxj = .true.
 
2512
    else
 
2513
      mp_netxj = .false.
 
2514
    endif
 
2515
    return
 
2516
  end function
 
2517
 
 
2518
  function mp_netjx (ja, xb)
 
2519
    implicit real*8 (d), type (mp_integer) (j), &
 
2520
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2521
    logical mp_netjx
 
2522
    intent (in):: ja, xb
 
2523
    type (mp_complex) z1, z2
 
2524
    integer mpnw
 
2525
    mpnw = mpnwx
 
2526
    call mpmzc (ja%mpi, z1%mpc)
 
2527
    call mpxzc (xb, z2%mpc)
 
2528
    call mpcpr (z1%mpc, z2%mpc, ic1, mpnw) 
 
2529
    call mpcpr (z1%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
2530
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
2531
      mp_netjx = .true.
 
2532
    else
 
2533
      mp_netjx = .false.
 
2534
    endif
 
2535
    return
 
2536
  end function
 
2537
 
 
2538
!  MPI .LE. routines.
 
2539
 
 
2540
  function mp_letjj (ja, jb)
 
2541
    implicit real*8 (d), type (mp_integer) (j), &
 
2542
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2543
    logical mp_letjj
 
2544
    intent (in):: ja, jb
 
2545
    integer mpnw
 
2546
    mpnw = mpnwx
 
2547
    call mpcpr (ja%mpi, jb%mpi, ic, mpnw) 
 
2548
    if (ic .le. 0) then
 
2549
      mp_letjj = .true.
 
2550
    else
 
2551
      mp_letjj = .false.
 
2552
    endif
 
2553
    return
 
2554
  end function
 
2555
 
 
2556
  function mp_letjq (ja, qb)
 
2557
    implicit real*8 (d), type (mp_integer) (j), &
 
2558
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2559
    logical mp_letjq
 
2560
    intent (in):: ja, qb
 
2561
    integer mpnw
 
2562
    mpnw = mpnwx
 
2563
    call mpcpr (ja%mpi, qb%mpr, ic, mpnw) 
 
2564
    if (ic .le. 0) then
 
2565
      mp_letjq = .true.
 
2566
    else
 
2567
      mp_letjq = .false.
 
2568
    endif
 
2569
    return
 
2570
  end function
 
2571
 
 
2572
  function mp_letij (ia, jb)
 
2573
    implicit real*8 (d), type (mp_integer) (j), &
 
2574
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2575
    logical mp_letij
 
2576
    intent (in):: ia, jb
 
2577
    type (mp_real) q1
 
2578
    integer mpnw
 
2579
    mpnw = mpnwx
 
2580
    da = ia
 
2581
    call mpdmc (da, 0, q1%mpr)
 
2582
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2583
    if (ic .le. 0) then
 
2584
      mp_letij = .true.
 
2585
    else
 
2586
      mp_letij = .false.
 
2587
    endif
 
2588
    return
 
2589
  end function
 
2590
 
 
2591
  function mp_letji (ja, ib)
 
2592
    implicit real*8 (d), type (mp_integer) (j), &
 
2593
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2594
    logical mp_letji
 
2595
    intent (in):: ja, ib
 
2596
    type (mp_real) q1
 
2597
    integer mpnw
 
2598
    mpnw = mpnwx
 
2599
    db = ib
 
2600
    call mpdmc (db, 0, q1%mpr)
 
2601
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2602
    if (ic .le. 0) then
 
2603
      mp_letji = .true.
 
2604
    else
 
2605
      mp_letji = .false.
 
2606
    endif
 
2607
    return
 
2608
  end function
 
2609
 
 
2610
  function mp_letdj (da, jb)
 
2611
    implicit real*8 (d), type (mp_integer) (j), &
 
2612
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2613
    logical mp_letdj
 
2614
    intent (in):: da, jb
 
2615
    type (mp_real) q1
 
2616
    integer mpnw
 
2617
    mpnw = mpnwx
 
2618
    call mpdmc (da, 0, q1%mpr)
 
2619
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2620
    if (ic .le. 0) then
 
2621
      mp_letdj = .true.
 
2622
    else
 
2623
      mp_letdj = .false.
 
2624
    endif
 
2625
    return
 
2626
  end function
 
2627
 
 
2628
  function mp_letjd (ja, db)
 
2629
    implicit real*8 (d), type (mp_integer) (j), &
 
2630
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2631
    logical mp_letjd
 
2632
    intent (in):: ja, db
 
2633
    type (mp_real) q1
 
2634
    integer mpnw
 
2635
    mpnw = mpnwx
 
2636
    call mpdmc (db, 0, q1%mpr)
 
2637
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2638
    if (ic .le. 0) then
 
2639
      mp_letjd = .true.
 
2640
    else
 
2641
      mp_letjd = .false.
 
2642
    endif
 
2643
    return
 
2644
  end function
 
2645
 
 
2646
!  MPI .GE. routines.
 
2647
 
 
2648
  function mp_getjj (ja, jb)
 
2649
    implicit real*8 (d), type (mp_integer) (j), &
 
2650
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2651
    logical mp_getjj
 
2652
    intent (in):: ja, jb
 
2653
    integer mpnw
 
2654
    mpnw = mpnwx
 
2655
    call mpcpr (ja%mpi, jb%mpi, ic, mpnw) 
 
2656
    if (ic .ge. 0) then
 
2657
      mp_getjj = .true.
 
2658
    else
 
2659
      mp_getjj = .false.
 
2660
    endif
 
2661
    return
 
2662
  end function
 
2663
 
 
2664
  function mp_getjq (ja, qb)
 
2665
    implicit real*8 (d), type (mp_integer) (j), &
 
2666
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2667
    logical mp_getjq
 
2668
    intent (in):: ja, qb
 
2669
    integer mpnw
 
2670
    mpnw = mpnwx
 
2671
    call mpcpr (ja%mpi, qb%mpr, ic, mpnw) 
 
2672
    if (ic .ge. 0) then
 
2673
      mp_getjq = .true.
 
2674
    else
 
2675
      mp_getjq = .false.
 
2676
    endif
 
2677
    return
 
2678
  end function
 
2679
 
 
2680
  function mp_getij (ia, jb)
 
2681
    implicit real*8 (d), type (mp_integer) (j), &
 
2682
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2683
    logical mp_getij
 
2684
    intent (in):: ia, jb
 
2685
    type (mp_real) q1
 
2686
    integer mpnw
 
2687
    mpnw = mpnwx
 
2688
    da = ia
 
2689
    call mpdmc (da, 0, q1%mpr)
 
2690
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2691
    if (ic .ge. 0) then
 
2692
      mp_getij = .true.
 
2693
    else
 
2694
      mp_getij = .false.
 
2695
    endif
 
2696
    return
 
2697
  end function
 
2698
 
 
2699
  function mp_getji (ja, ib)
 
2700
    implicit real*8 (d), type (mp_integer) (j), &
 
2701
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2702
    logical mp_getji
 
2703
    intent (in):: ja, ib
 
2704
    type (mp_real) q1
 
2705
    integer mpnw
 
2706
    mpnw = mpnwx
 
2707
    db = ib
 
2708
    call mpdmc (db, 0, q1%mpr)
 
2709
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2710
    if (ic .ge. 0) then
 
2711
      mp_getji = .true.
 
2712
    else
 
2713
      mp_getji = .false.
 
2714
    endif
 
2715
    return
 
2716
  end function
 
2717
 
 
2718
  function mp_getdj (da, jb)
 
2719
    implicit real*8 (d), type (mp_integer) (j), &
 
2720
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2721
    logical mp_getdj
 
2722
    intent (in):: da, jb
 
2723
    type (mp_real) q1
 
2724
    integer mpnw
 
2725
    mpnw = mpnwx
 
2726
    call mpdmc (da, 0, q1%mpr)
 
2727
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2728
    if (ic .ge. 0) then
 
2729
      mp_getdj = .true.
 
2730
    else
 
2731
      mp_getdj = .false.
 
2732
    endif
 
2733
    return
 
2734
  end function
 
2735
 
 
2736
  function mp_getjd (ja, db)
 
2737
    implicit real*8 (d), type (mp_integer) (j), &
 
2738
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2739
    logical mp_getjd
 
2740
    intent (in):: ja, db
 
2741
    type (mp_real) q1
 
2742
    integer mpnw
 
2743
    mpnw = mpnwx
 
2744
    call mpdmc (db, 0, q1%mpr)
 
2745
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2746
    if (ic .ge. 0) then
 
2747
      mp_getjd = .true.
 
2748
    else
 
2749
      mp_getjd = .false.
 
2750
    endif
 
2751
    return
 
2752
  end function
 
2753
 
 
2754
!  MPI .LT. routines.
 
2755
 
 
2756
  function mp_lttjj (ja, jb)
 
2757
    implicit real*8 (d), type (mp_integer) (j), &
 
2758
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2759
    logical mp_lttjj
 
2760
    intent (in):: ja, jb
 
2761
    integer mpnw
 
2762
    mpnw = mpnwx
 
2763
    call mpcpr (ja%mpi, jb%mpi, ic, mpnw) 
 
2764
    if (ic .lt. 0) then
 
2765
      mp_lttjj = .true.
 
2766
    else
 
2767
      mp_lttjj = .false.
 
2768
    endif
 
2769
    return
 
2770
  end function
 
2771
 
 
2772
  function mp_lttjq (ja, qb)
 
2773
    implicit real*8 (d), type (mp_integer) (j), &
 
2774
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2775
    logical mp_lttjq
 
2776
    intent (in):: ja, qb
 
2777
    integer mpnw
 
2778
    mpnw = mpnwx
 
2779
    call mpcpr (ja%mpi, qb%mpr, ic, mpnw) 
 
2780
    if (ic .lt. 0) then
 
2781
      mp_lttjq = .true.
 
2782
    else
 
2783
      mp_lttjq = .false.
 
2784
    endif
 
2785
    return
 
2786
  end function
 
2787
 
 
2788
  function mp_lttij (ia, jb)
 
2789
    implicit real*8 (d), type (mp_integer) (j), &
 
2790
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2791
    logical mp_lttij
 
2792
    intent (in):: ia, jb
 
2793
    type (mp_real) q1
 
2794
    integer mpnw
 
2795
    mpnw = mpnwx
 
2796
    da = ia
 
2797
    call mpdmc (da, 0, q1%mpr)
 
2798
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2799
    if (ic .lt. 0) then
 
2800
      mp_lttij = .true.
 
2801
    else
 
2802
      mp_lttij = .false.
 
2803
    endif
 
2804
    return
 
2805
  end function
 
2806
 
 
2807
  function mp_lttji (ja, ib)
 
2808
    implicit real*8 (d), type (mp_integer) (j), &
 
2809
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2810
    logical mp_lttji
 
2811
    intent (in):: ja, ib
 
2812
    type (mp_real) q1
 
2813
    integer mpnw
 
2814
    mpnw = mpnwx
 
2815
    db = ib
 
2816
    call mpdmc (db, 0, q1%mpr)
 
2817
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2818
    if (ic .lt. 0) then
 
2819
      mp_lttji = .true.
 
2820
    else
 
2821
      mp_lttji = .false.
 
2822
    endif
 
2823
    return
 
2824
  end function
 
2825
 
 
2826
  function mp_lttdj (da, jb)
 
2827
    implicit real*8 (d), type (mp_integer) (j), &
 
2828
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2829
    logical mp_lttdj
 
2830
    intent (in):: da, jb
 
2831
    type (mp_real) q1
 
2832
    integer mpnw
 
2833
    mpnw = mpnwx
 
2834
    call mpdmc (da, 0, q1%mpr)
 
2835
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2836
    if (ic .lt. 0) then
 
2837
      mp_lttdj = .true.
 
2838
    else
 
2839
      mp_lttdj = .false.
 
2840
    endif
 
2841
    return
 
2842
  end function
 
2843
 
 
2844
  function mp_lttjd (ja, db)
 
2845
    implicit real*8 (d), type (mp_integer) (j), &
 
2846
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2847
    logical mp_lttjd
 
2848
    intent (in):: ja, db
 
2849
    type (mp_real) q1
 
2850
    integer mpnw
 
2851
    mpnw = mpnwx
 
2852
    call mpdmc (db, 0, q1%mpr)
 
2853
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2854
    if (ic .lt. 0) then
 
2855
      mp_lttjd = .true.
 
2856
    else
 
2857
      mp_lttjd = .false.
 
2858
    endif
 
2859
    return
 
2860
  end function
 
2861
 
 
2862
!  MPI .GT. routines.
 
2863
 
 
2864
  function mp_gttjj (ja, jb)
 
2865
    implicit real*8 (d), type (mp_integer) (j), &
 
2866
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2867
    logical mp_gttjj
 
2868
    intent (in):: ja, jb
 
2869
    integer mpnw
 
2870
    mpnw = mpnwx
 
2871
    call mpcpr (ja%mpi, jb%mpi, ic, mpnw) 
 
2872
    if (ic .gt. 0) then
 
2873
      mp_gttjj = .true.
 
2874
    else
 
2875
      mp_gttjj = .false.
 
2876
    endif
 
2877
    return
 
2878
  end function
 
2879
 
 
2880
  function mp_gttjq (ja, qb)
 
2881
    implicit real*8 (d), type (mp_integer) (j), &
 
2882
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2883
    logical mp_gttjq
 
2884
    intent (in):: ja, qb
 
2885
    integer mpnw
 
2886
    mpnw = mpnwx
 
2887
    call mpcpr (ja%mpi, qb%mpr, ic, mpnw) 
 
2888
    if (ic .gt. 0) then
 
2889
      mp_gttjq = .true.
 
2890
    else
 
2891
      mp_gttjq = .false.
 
2892
    endif
 
2893
    return
 
2894
  end function
 
2895
 
 
2896
  function mp_gttij (ia, jb)
 
2897
    implicit real*8 (d), type (mp_integer) (j), &
 
2898
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2899
    logical mp_gttij
 
2900
    intent (in):: ia, jb
 
2901
    type (mp_real) q1
 
2902
    integer mpnw
 
2903
    mpnw = mpnwx
 
2904
    da = ia
 
2905
    call mpdmc (da, 0, q1%mpr)
 
2906
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2907
    if (ic .gt. 0) then
 
2908
      mp_gttij = .true.
 
2909
    else
 
2910
      mp_gttij = .false.
 
2911
    endif
 
2912
    return
 
2913
  end function
 
2914
 
 
2915
  function mp_gttji (ja, ib)
 
2916
    implicit real*8 (d), type (mp_integer) (j), &
 
2917
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2918
    logical mp_gttji
 
2919
    intent (in):: ja, ib
 
2920
    type (mp_real) q1
 
2921
    integer mpnw
 
2922
    mpnw = mpnwx
 
2923
    db = ib
 
2924
    call mpdmc (db, 0, q1%mpr)
 
2925
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2926
    if (ic .gt. 0) then
 
2927
      mp_gttji = .true.
 
2928
    else
 
2929
      mp_gttji = .false.
 
2930
    endif
 
2931
    return
 
2932
  end function
 
2933
 
 
2934
  function mp_gttdj (da, jb)
 
2935
    implicit real*8 (d), type (mp_integer) (j), &
 
2936
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2937
    logical mp_gttdj
 
2938
    intent (in):: da, jb
 
2939
    type (mp_real) q1
 
2940
    integer mpnw
 
2941
    mpnw = mpnwx
 
2942
    call mpdmc (da, 0, q1%mpr)
 
2943
    call mpcpr (q1%mpr, jb%mpi, ic, mpnw) 
 
2944
    if (ic .gt. 0) then
 
2945
      mp_gttdj = .true.
 
2946
    else
 
2947
      mp_gttdj = .false.
 
2948
    endif
 
2949
    return
 
2950
  end function
 
2951
 
 
2952
  function mp_gttjd (ja, db)
 
2953
    implicit real*8 (d), type (mp_integer) (j), &
 
2954
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
2955
    logical mp_gttjd
 
2956
    intent (in):: ja, db
 
2957
    type (mp_real) q1
 
2958
    integer mpnw
 
2959
    mpnw = mpnwx
 
2960
    call mpdmc (db, 0, q1%mpr)
 
2961
    call mpcpr (ja%mpi, q1%mpr, ic, mpnw) 
 
2962
    if (ic .gt. 0) then
 
2963
      mp_gttjd = .true.
 
2964
    else
 
2965
      mp_gttjd = .false.
 
2966
    endif
 
2967
    return
 
2968
  end function
 
2969
 
 
2970
end module
 
2971
 
 
2972
 
 
2973
module mprealmod
 
2974
 
 
2975
!  This Fortran-90 module defines operator extensions involving the
 
2976
!  MP_REAL datatype.  For operations involving two MP data types,
 
2977
!  those whose first argument is MP_REAL are included here.
 
2978
!  Others are handled in other modules.
 
2979
 
 
2980
!  The subroutines and functions defined in this module are private
 
2981
!  and not intended to be called directly by the user.
 
2982
 
 
2983
use mpfunmod
 
2984
use mpdefmod
 
2985
private kdb, mp4, mp24, mp41
 
2986
parameter (kdb = kind (0.d0), mp4 = mpwds + 4, mp24 = 2 * mp4, mp41 = mp4 + 1)
 
2987
private &
 
2988
  mp_eqqj, mp_eqqq, mp_eqqz, mp_eqiq, mp_eqqi, &
 
2989
  mp_eqdq, mp_eqqd, mp_eqxq, mp_eqqx, mp_eqqa, &
 
2990
  mp_addqj, mp_addqq, mp_addqz, mp_addiq, mp_addqi, &
 
2991
  mp_adddq, mp_addqd, mp_addxq, mp_addqx, &
 
2992
  mp_subqj, mp_subqq, mp_subqz, mp_subiq, mp_subqi, &
 
2993
  mp_subdq, mp_subqd, mp_subxq, mp_subqx, mp_negq, &
 
2994
  mp_mulqj, mp_mulqq, mp_mulqz, mp_muliq, mp_mulqi, &
 
2995
  mp_muldq, mp_mulqd, mp_mulxq, mp_mulqx, &
 
2996
  mp_divqj, mp_divqq, mp_divqz, mp_diviq, mp_divqi, &
 
2997
  mp_divdq, mp_divqd, mp_divxq, mp_divqx, &
 
2998
  mp_expqj, mp_expqq, mp_expiq, mp_expqi, mp_expdq, mp_expqd, &
 
2999
  mp_eqtqj, mp_eqtqq, mp_eqtqz, mp_eqtiq, mp_eqtqi, &
 
3000
  mp_eqtdq, mp_eqtqd, mp_eqtxq, mp_eqtqx, &
 
3001
  mp_netqj, mp_netqq, mp_netqz, mp_netiq, mp_netqi, &
 
3002
  mp_netdq, mp_netqd, mp_netxq, mp_netqx, &
 
3003
  mp_letqj, mp_letqq, mp_letiq, mp_letqi, mp_letdq, mp_letqd, &
 
3004
  mp_getqj, mp_getqq, mp_getiq, mp_getqi, mp_getdq, mp_getqd, &
 
3005
  mp_lttqj, mp_lttqq, mp_lttiq, mp_lttqi, mp_lttdq, mp_lttqd, &
 
3006
  mp_gttqj, mp_gttqq, mp_gttiq, mp_gttqi, mp_gttdq, mp_gttqd
 
3007
 
 
3008
!  MPR operator extension interface blocks.
 
3009
 
 
3010
interface assignment (=)
 
3011
  module procedure mp_eqqj
 
3012
  module procedure mp_eqqq
 
3013
  module procedure mp_eqqz
 
3014
  module procedure mp_eqiq
 
3015
  module procedure mp_eqqi
 
3016
  module procedure mp_eqdq
 
3017
  module procedure mp_eqqd
 
3018
  module procedure mp_eqxq
 
3019
  module procedure mp_eqqx
 
3020
 
 
3021
  module procedure mp_eqqa
 
3022
end interface
 
3023
 
 
3024
interface operator (+)
 
3025
  module procedure mp_addqj
 
3026
  module procedure mp_addqq
 
3027
  module procedure mp_addqz
 
3028
  module procedure mp_addiq
 
3029
  module procedure mp_addqi
 
3030
  module procedure mp_adddq
 
3031
  module procedure mp_addqd
 
3032
  module procedure mp_addxq
 
3033
  module procedure mp_addqx
 
3034
end interface
 
3035
 
 
3036
interface operator (-)
 
3037
  module procedure mp_subqj
 
3038
  module procedure mp_subqq
 
3039
  module procedure mp_subqz
 
3040
  module procedure mp_subiq
 
3041
  module procedure mp_subqi
 
3042
  module procedure mp_subdq
 
3043
  module procedure mp_subqd
 
3044
  module procedure mp_subxq
 
3045
  module procedure mp_subqx
 
3046
 
 
3047
  module procedure mp_negq
 
3048
end interface
 
3049
 
 
3050
interface operator (*)
 
3051
  module procedure mp_mulqj
 
3052
  module procedure mp_mulqq
 
3053
  module procedure mp_mulqz
 
3054
  module procedure mp_muliq
 
3055
  module procedure mp_mulqi
 
3056
  module procedure mp_muldq
 
3057
  module procedure mp_mulqd
 
3058
  module procedure mp_mulxq
 
3059
  module procedure mp_mulqx
 
3060
end interface
 
3061
 
 
3062
interface operator (/)
 
3063
  module procedure mp_divqj
 
3064
  module procedure mp_divqq
 
3065
  module procedure mp_divqz
 
3066
  module procedure mp_diviq
 
3067
  module procedure mp_divqi
 
3068
  module procedure mp_divdq
 
3069
  module procedure mp_divqd
 
3070
  module procedure mp_divxq
 
3071
  module procedure mp_divqx
 
3072
end interface
 
3073
 
 
3074
interface operator (**)
 
3075
  module procedure mp_expqj
 
3076
  module procedure mp_expqq
 
3077
  module procedure mp_expiq
 
3078
  module procedure mp_expqi
 
3079
  module procedure mp_expdq
 
3080
  module procedure mp_expqd
 
3081
end interface
 
3082
 
 
3083
interface operator (.eq.)
 
3084
  module procedure mp_eqtqj
 
3085
  module procedure mp_eqtqq
 
3086
  module procedure mp_eqtqz
 
3087
  module procedure mp_eqtiq
 
3088
  module procedure mp_eqtqi
 
3089
  module procedure mp_eqtdq
 
3090
  module procedure mp_eqtqd
 
3091
  module procedure mp_eqtxq
 
3092
  module procedure mp_eqtqx
 
3093
end interface
 
3094
 
 
3095
interface operator (.ne.)
 
3096
  module procedure mp_netqj
 
3097
  module procedure mp_netqq
 
3098
  module procedure mp_netqz
 
3099
  module procedure mp_netiq
 
3100
  module procedure mp_netqi
 
3101
  module procedure mp_netdq
 
3102
  module procedure mp_netqd
 
3103
  module procedure mp_netxq
 
3104
  module procedure mp_netqx
 
3105
end interface
 
3106
 
 
3107
interface operator (.le.)
 
3108
  module procedure mp_letqj
 
3109
  module procedure mp_letqq
 
3110
  module procedure mp_letiq
 
3111
  module procedure mp_letqi
 
3112
  module procedure mp_letdq
 
3113
  module procedure mp_letqd
 
3114
end interface
 
3115
 
 
3116
interface operator (.ge.)
 
3117
  module procedure mp_getqj
 
3118
  module procedure mp_getqq
 
3119
  module procedure mp_getiq
 
3120
  module procedure mp_getqi
 
3121
  module procedure mp_getdq
 
3122
  module procedure mp_getqd
 
3123
end interface
 
3124
 
 
3125
interface operator (.lt.)
 
3126
  module procedure mp_lttqj
 
3127
  module procedure mp_lttqq
 
3128
  module procedure mp_lttiq
 
3129
  module procedure mp_lttqi
 
3130
  module procedure mp_lttdq
 
3131
  module procedure mp_lttqd
 
3132
end interface
 
3133
 
 
3134
interface operator (.gt.)
 
3135
  module procedure mp_gttqj
 
3136
  module procedure mp_gttqq
 
3137
  module procedure mp_gttiq
 
3138
  module procedure mp_gttqi
 
3139
  module procedure mp_gttdq
 
3140
  module procedure mp_gttqd
 
3141
end interface
 
3142
 
 
3143
contains
 
3144
 
 
3145
!  MPR assignment routines.
 
3146
 
 
3147
  subroutine mp_eqqj (qa, jb)
 
3148
    implicit real*8 (d), type (mp_integer) (j), &
 
3149
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3150
    intent (out):: qa
 
3151
    intent (in):: jb
 
3152
    integer mpnw
 
3153
    mpnw = mpnwx
 
3154
    call mpeq (jb%mpi, qa%mpr, mpnw) 
 
3155
    return
 
3156
  end subroutine
 
3157
 
 
3158
  subroutine mp_eqqq (qa, qb)
 
3159
    implicit real*8 (d), type (mp_integer) (j), &
 
3160
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3161
    intent (out):: qa
 
3162
    intent (in):: qb
 
3163
    integer mpnw
 
3164
    mpnw = mpnwx
 
3165
    call mpeq (qb%mpr, qa%mpr, mpnw) 
 
3166
    return
 
3167
  end subroutine
 
3168
 
 
3169
  subroutine mp_eqqz (qa, zb)
 
3170
    implicit real*8 (d), type (mp_integer) (j), &
 
3171
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3172
    intent (out):: qa
 
3173
    intent (in):: zb
 
3174
    integer mpnw
 
3175
    mpnw = mpnwx
 
3176
    call mpeq (zb%mpc, qa%mpr, mpnw) 
 
3177
    return
 
3178
  end subroutine
 
3179
 
 
3180
  subroutine mp_eqiq (ia, qb)
 
3181
    implicit real*8 (d), type (mp_integer) (j), &
 
3182
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3183
    intent (out):: ia
 
3184
    intent (in):: qb
 
3185
    integer mpnw
 
3186
    mpnw = mpnwx
 
3187
    call mpmdc (qb%mpr, db, ib)
 
3188
    ia = db * 2.d0 ** ib
 
3189
    return
 
3190
  end subroutine
 
3191
 
 
3192
  subroutine mp_eqqi (qa, ib)
 
3193
    implicit real*8 (d), type (mp_integer) (j), &
 
3194
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3195
    intent (out):: qa
 
3196
    intent (in):: ib
 
3197
    integer mpnw
 
3198
    mpnw = mpnwx
 
3199
    db = ib
 
3200
    call mpdmc (db, 0, qa%mpr)
 
3201
    return
 
3202
  end subroutine
 
3203
 
 
3204
  subroutine mp_eqdq (da, qb)
 
3205
    implicit real*8 (d), type (mp_integer) (j), &
 
3206
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3207
    intent (out):: da
 
3208
    intent (in):: qb
 
3209
    integer mpnw
 
3210
    mpnw = mpnwx
 
3211
    call mpmdc (qb%mpr, db, ib)
 
3212
    da = db * 2.d0 ** ib
 
3213
    return
 
3214
  end subroutine
 
3215
 
 
3216
  subroutine mp_eqqd (qa, db)
 
3217
    implicit real*8 (d), type (mp_integer) (j), &
 
3218
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3219
    intent (out):: qa
 
3220
    intent (in):: db
 
3221
    integer mpnw
 
3222
    mpnw = mpnwx
 
3223
    call mpdmc (db, 0, qa%mpr)
 
3224
    return
 
3225
  end subroutine
 
3226
 
 
3227
  subroutine mp_eqxq (xa, qb)
 
3228
    implicit real*8 (d), type (mp_integer) (j), &
 
3229
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3230
    intent (out):: xa
 
3231
    intent (in):: qb
 
3232
    integer mpnw
 
3233
    mpnw = mpnwx
 
3234
    call mpmdc (qb%mpr, db, ib)
 
3235
    xa = db * 2.d0 ** ib
 
3236
    return
 
3237
  end subroutine
 
3238
 
 
3239
  subroutine mp_eqqx (qa, xb)
 
3240
    implicit real*8 (d), type (mp_integer) (j), &
 
3241
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3242
    intent (out):: qa
 
3243
    intent (in):: xb
 
3244
    integer mpnw
 
3245
    mpnw = mpnwx
 
3246
    db = xb
 
3247
    call mpdmc (db, 0, qa%mpr)
 
3248
    return
 
3249
  end subroutine
 
3250
 
 
3251
  subroutine mp_eqqa (qa, ab)
 
3252
    implicit real*8 (d), type (mp_integer) (j), &
 
3253
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3254
    character*(*), intent (in):: ab
 
3255
    intent (out):: qa
 
3256
    character*1 az(mpipl+100)
 
3257
    integer mpnw
 
3258
    mpnw = mpnwx
 
3259
    l = len (ab)
 
3260
    do i = 1, l
 
3261
      az(i) = ab(i:i)
 
3262
    enddo
 
3263
    call mpdexc (az, l, qa%mpr, mpnw) 
 
3264
    return
 
3265
  end subroutine
 
3266
 
 
3267
!  MPR add routines.
 
3268
 
 
3269
  function mp_addqj (qa, jb)
 
3270
    implicit real*8 (d), type (mp_integer) (j), &
 
3271
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3272
    type (mp_real):: mp_addqj
 
3273
    intent (in):: qa, jb
 
3274
    integer mpnw
 
3275
    mpnw = mpnwx
 
3276
    call mpadd (qa%mpr, jb%mpi, mp_addqj%mpr, mpnw) 
 
3277
    return
 
3278
  end function
 
3279
 
 
3280
  function mp_addqq (qa, qb)
 
3281
    implicit real*8 (d), type (mp_integer) (j), &
 
3282
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3283
    type (mp_real):: mp_addqq
 
3284
    intent (in):: qa, qb
 
3285
    integer mpnw
 
3286
    mpnw = mpnwx
 
3287
    call mpadd (qa%mpr, qb%mpr, mp_addqq%mpr, mpnw) 
 
3288
    return
 
3289
  end function
 
3290
 
 
3291
  function mp_addqz (qa, zb)
 
3292
    implicit real*8 (d), type (mp_integer) (j), &
 
3293
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3294
    type (mp_complex):: mp_addqz
 
3295
    intent (in):: qa, zb
 
3296
    type (mp_complex) z1
 
3297
    integer mpnw
 
3298
    mpnw = mpnwx
 
3299
    call mpmzc (qa%mpr, z1%mpc)
 
3300
    call mpcadd (mp4, z1%mpc, zb%mpc, mp_addqz%mpc, mpnw) 
 
3301
    return
 
3302
  end function
 
3303
 
 
3304
  function mp_addiq (ia, qb)
 
3305
    implicit real*8 (d), type (mp_integer) (j), &
 
3306
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3307
    type (mp_real):: mp_addiq
 
3308
    intent (in):: ia, qb
 
3309
    type (mp_real) q1
 
3310
    integer mpnw
 
3311
    mpnw = mpnwx
 
3312
    da = ia
 
3313
    call mpdmc (da, 0, q1%mpr)
 
3314
    call mpadd (q1%mpr, qb%mpr, mp_addiq%mpr, mpnw) 
 
3315
    return
 
3316
  end function
 
3317
 
 
3318
  function mp_addqi (qa, ib)
 
3319
    implicit real*8 (d), type (mp_integer) (j), &
 
3320
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3321
    type (mp_real):: mp_addqi
 
3322
    intent (in):: qa, ib
 
3323
    type (mp_real) q1
 
3324
    integer mpnw
 
3325
    mpnw = mpnwx
 
3326
    db = ib
 
3327
    call mpdmc (db, 0, q1%mpr)
 
3328
    call mpadd (qa%mpr, q1%mpr, mp_addqi%mpr, mpnw) 
 
3329
    return
 
3330
  end function
 
3331
 
 
3332
  function mp_adddq (da, qb)
 
3333
    implicit real*8 (d), type (mp_integer) (j), &
 
3334
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3335
    type (mp_real):: mp_adddq
 
3336
    intent (in):: da, qb
 
3337
    type (mp_real) q1
 
3338
    integer mpnw
 
3339
    mpnw = mpnwx
 
3340
    call mpdmc (da, 0, q1%mpr)
 
3341
    call mpadd (q1%mpr, qb%mpr, mp_adddq%mpr, mpnw) 
 
3342
    return
 
3343
  end function
 
3344
 
 
3345
  function mp_addqd (qa, db)
 
3346
    implicit real*8 (d), type (mp_integer) (j), &
 
3347
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3348
    type (mp_real):: mp_addqd
 
3349
    intent (in):: qa, db
 
3350
    type (mp_real) q1
 
3351
    integer mpnw
 
3352
    mpnw = mpnwx
 
3353
    call mpdmc (db, 0, q1%mpr)
 
3354
    call mpadd (qa%mpr, q1%mpr, mp_addqd%mpr, mpnw) 
 
3355
    return
 
3356
  end function
 
3357
 
 
3358
  function mp_addxq (xa, qb)
 
3359
    implicit real*8 (d), type (mp_integer) (j), &
 
3360
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3361
    type (mp_complex):: mp_addxq
 
3362
    intent (in):: xa, qb
 
3363
    type (mp_complex) z1, z2
 
3364
    integer mpnw
 
3365
    mpnw = mpnwx
 
3366
    call mpxzc (xa, z1%mpc)
 
3367
    call mpmzc (qb%mpr, z2%mpc)
 
3368
    call mpcadd (mp4, z1%mpc, z2%mpc, mp_addxq%mpc, mpnw) 
 
3369
    return
 
3370
  end function
 
3371
 
 
3372
  function mp_addqx (qa, xb)
 
3373
    implicit real*8 (d), type (mp_integer) (j), &
 
3374
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3375
    type (mp_complex):: mp_addqx
 
3376
    intent (in):: qa, xb
 
3377
    type (mp_complex) z1, z2
 
3378
    integer mpnw
 
3379
    mpnw = mpnwx
 
3380
    call mpmzc (qa%mpr, z1%mpc)
 
3381
    call mpxzc (xb, z2%mpc)
 
3382
    call mpcadd (mp4, z1%mpc, z2%mpc, mp_addqx%mpc, mpnw) 
 
3383
    return
 
3384
  end function
 
3385
 
 
3386
!  MPR subtract routines.
 
3387
 
 
3388
  function mp_subqj (qa, jb)
 
3389
    implicit real*8 (d), type (mp_integer) (j), &
 
3390
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3391
    type (mp_real):: mp_subqj
 
3392
    intent (in):: qa, jb
 
3393
    integer mpnw
 
3394
    mpnw = mpnwx
 
3395
    call mpsub (qa%mpr, jb%mpi, mp_subqj%mpr, mpnw) 
 
3396
    return
 
3397
  end function
 
3398
 
 
3399
  function mp_subqq (qa, qb)
 
3400
    implicit real*8 (d), type (mp_integer) (j), &
 
3401
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3402
    type (mp_real):: mp_subqq
 
3403
    intent (in):: qa, qb
 
3404
    integer mpnw
 
3405
    mpnw = mpnwx
 
3406
    call mpsub (qa%mpr, qb%mpr, mp_subqq%mpr, mpnw) 
 
3407
    return
 
3408
  end function
 
3409
 
 
3410
  function mp_subqz (qa, zb)
 
3411
    implicit real*8 (d), type (mp_integer) (j), &
 
3412
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3413
    type (mp_complex):: mp_subqz
 
3414
    intent (in):: qa, zb
 
3415
    type (mp_complex) z1
 
3416
    integer mpnw
 
3417
    mpnw = mpnwx
 
3418
    call mpmzc (qa%mpr, z1%mpc)
 
3419
    call mpcsub (mp4, z1%mpc, zb%mpc, mp_subqz%mpc, mpnw) 
 
3420
    return
 
3421
  end function
 
3422
 
 
3423
  function mp_subiq (ia, qb)
 
3424
    implicit real*8 (d), type (mp_integer) (j), &
 
3425
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3426
    type (mp_real):: mp_subiq
 
3427
    intent (in):: ia, qb
 
3428
    type (mp_real) q1
 
3429
    integer mpnw
 
3430
    mpnw = mpnwx
 
3431
    da = ia
 
3432
    call mpdmc (da, 0, q1%mpr)
 
3433
    call mpsub (q1%mpr, qb%mpr, mp_subiq%mpr, mpnw) 
 
3434
    return
 
3435
  end function
 
3436
 
 
3437
  function mp_subqi (qa, ib)
 
3438
    implicit real*8 (d), type (mp_integer) (j), &
 
3439
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3440
    type (mp_real):: mp_subqi
 
3441
    intent (in):: qa, ib
 
3442
    type (mp_real) q1
 
3443
    integer mpnw
 
3444
    mpnw = mpnwx
 
3445
    db = ib
 
3446
    call mpdmc (db, 0, q1%mpr)
 
3447
    call mpsub (qa%mpr, q1%mpr, mp_subqi%mpr, mpnw) 
 
3448
    return
 
3449
  end function
 
3450
 
 
3451
  function mp_subdq (da, qb)
 
3452
    implicit real*8 (d), type (mp_integer) (j), &
 
3453
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3454
    type (mp_real):: mp_subdq
 
3455
    intent (in):: da, qb
 
3456
    type (mp_real) q1
 
3457
    integer mpnw
 
3458
    mpnw = mpnwx
 
3459
    call mpdmc (da, 0, q1%mpr)
 
3460
    call mpsub (q1%mpr, qb%mpr, mp_subdq%mpr, mpnw) 
 
3461
    return
 
3462
  end function
 
3463
 
 
3464
  function mp_subqd (qa, db)
 
3465
    implicit real*8 (d), type (mp_integer) (j), &
 
3466
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3467
    type (mp_real):: mp_subqd
 
3468
    intent (in):: qa, db
 
3469
    type (mp_real) q1
 
3470
    integer mpnw
 
3471
    mpnw = mpnwx
 
3472
    call mpdmc (db, 0, q1%mpr)
 
3473
    call mpsub (qa%mpr, q1%mpr, mp_subqd%mpr, mpnw) 
 
3474
    return
 
3475
  end function
 
3476
 
 
3477
  function mp_subxq (xa, qb)
 
3478
    implicit real*8 (d), type (mp_integer) (j), &
 
3479
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3480
    type (mp_complex):: mp_subxq
 
3481
    intent (in):: xa, qb
 
3482
    type (mp_complex) z1, z2
 
3483
    integer mpnw
 
3484
    mpnw = mpnwx
 
3485
    call mpxzc (xa, z1%mpc)
 
3486
    call mpmzc (qb%mpr, z2%mpc)
 
3487
    call mpcsub (mp4, z1%mpc, z2%mpc, mp_subxq%mpc, mpnw) 
 
3488
    return
 
3489
  end function
 
3490
 
 
3491
  function mp_subqx (qa, xb)
 
3492
    implicit real*8 (d), type (mp_integer) (j), &
 
3493
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3494
    type (mp_complex):: mp_subqx
 
3495
    intent (in):: qa, xb
 
3496
    type (mp_complex) z1, z2
 
3497
    integer mpnw
 
3498
    mpnw = mpnwx
 
3499
    call mpmzc (qa%mpr, z1%mpc)
 
3500
    call mpxzc (xb, z2%mpc)
 
3501
    call mpcsub (mp4, z1%mpc, z2%mpc, mp_subqx%mpc, mpnw) 
 
3502
    return
 
3503
  end function
 
3504
 
 
3505
!  MPR negation routine.
 
3506
 
 
3507
  function mp_negq (qa)
 
3508
    implicit real*8 (d), type (mp_integer) (j), &
 
3509
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3510
    type (mp_real):: mp_negq
 
3511
    intent (in):: qa
 
3512
    integer mpnw
 
3513
    mpnw = mpnwx
 
3514
    call mpeq (qa%mpr, mp_negq%mpr, mpnw) 
 
3515
    mp_negq%mpr(1) = - qa%mpr(1)
 
3516
    return
 
3517
  end function
 
3518
 
 
3519
!  MPR multiply routines.
 
3520
 
 
3521
  function mp_mulqj (qa, jb)
 
3522
    implicit real*8 (d), type (mp_integer) (j), &
 
3523
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3524
    type (mp_real):: mp_mulqj
 
3525
    intent (in):: qa, jb
 
3526
    integer mpnw
 
3527
    mpnw = mpnwx
 
3528
    call mpmul (qa%mpr, jb%mpi, mp_mulqj%mpr, mpnw) 
 
3529
    return
 
3530
  end function
 
3531
 
 
3532
  function mp_mulqq (qa, qb)
 
3533
    implicit real*8 (d), type (mp_integer) (j), &
 
3534
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3535
    type (mp_real):: mp_mulqq
 
3536
    intent (in):: qa, qb
 
3537
    integer mpnw
 
3538
    mpnw = mpnwx
 
3539
    call mpmul (qa%mpr, qb%mpr, mp_mulqq%mpr, mpnw) 
 
3540
    return
 
3541
  end function
 
3542
 
 
3543
  function mp_mulqz (qa, zb)
 
3544
    implicit real*8 (d), type (mp_integer) (j), &
 
3545
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3546
    type (mp_complex):: mp_mulqz
 
3547
    intent (in):: qa, zb
 
3548
    type (mp_complex) z1
 
3549
    integer mpnw
 
3550
    mpnw = mpnwx
 
3551
    call mpmzc (qa%mpr, z1%mpc)
 
3552
    call mpcmul (mp4, z1%mpc, zb%mpc, mp_mulqz%mpc, mpnw) 
 
3553
    return
 
3554
  end function
 
3555
 
 
3556
  function mp_muliq (ia, qb)
 
3557
    implicit real*8 (d), type (mp_integer) (j), &
 
3558
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3559
    type (mp_real):: mp_muliq
 
3560
    intent (in):: ia, qb
 
3561
    integer mpnw
 
3562
    mpnw = mpnwx
 
3563
    da = ia
 
3564
    call mpmuld (qb%mpr, da, 0, mp_muliq%mpr, mpnw) 
 
3565
    return
 
3566
  end function
 
3567
 
 
3568
  function mp_mulqi (qa, ib)
 
3569
    implicit real*8 (d), type (mp_integer) (j), &
 
3570
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3571
    type (mp_real):: mp_mulqi
 
3572
    intent (in):: qa, ib
 
3573
    integer mpnw
 
3574
    mpnw = mpnwx
 
3575
    db = ib
 
3576
    call mpmuld (qa%mpr, db, 0, mp_mulqi%mpr, mpnw) 
 
3577
    return
 
3578
  end function
 
3579
 
 
3580
  function mp_muldq (da, qb)
 
3581
    implicit real*8 (d), type (mp_integer) (j), &
 
3582
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3583
    type (mp_real):: mp_muldq
 
3584
    intent (in):: da, qb
 
3585
    integer mpnw
 
3586
    mpnw = mpnwx
 
3587
    call mpmuld (qb%mpr, da, 0, mp_muldq%mpr, mpnw) 
 
3588
    return
 
3589
  end function
 
3590
 
 
3591
  function mp_mulqd (qa, db)
 
3592
    implicit real*8 (d), type (mp_integer) (j), &
 
3593
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3594
    type (mp_real):: mp_mulqd
 
3595
    intent (in):: qa, db
 
3596
    integer mpnw
 
3597
    mpnw = mpnwx
 
3598
    call mpmuld (qa%mpr, db, 0, mp_mulqd%mpr, mpnw) 
 
3599
    return
 
3600
  end function
 
3601
 
 
3602
  function mp_mulxq (xa, qb)
 
3603
    implicit real*8 (d), type (mp_integer) (j), &
 
3604
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3605
    type (mp_complex):: mp_mulxq
 
3606
    intent (in):: xa, qb
 
3607
    type (mp_complex) z1, z2
 
3608
    integer mpnw
 
3609
    mpnw = mpnwx
 
3610
    call mpxzc (xa, z1%mpc)
 
3611
    call mpmzc (qb%mpr, z2%mpc)
 
3612
    call mpcmul (mp4, z1%mpc, z2%mpc, mp_mulxq%mpc, mpnw) 
 
3613
    return
 
3614
  end function
 
3615
 
 
3616
  function mp_mulqx (qa, xb)
 
3617
    implicit real*8 (d), type (mp_integer) (j), &
 
3618
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3619
    type (mp_complex):: mp_mulqx
 
3620
    intent (in):: qa, xb
 
3621
    type (mp_complex) z1, z2
 
3622
    integer mpnw
 
3623
    mpnw = mpnwx
 
3624
    call mpmzc (qa%mpr, z1%mpc)
 
3625
    call mpxzc (xb, z2%mpc)
 
3626
    call mpcmul (mp4, z1%mpc, z2%mpc, mp_mulqx%mpc, mpnw) 
 
3627
    return
 
3628
  end function
 
3629
 
 
3630
!  MPR divide routines.
 
3631
 
 
3632
  function mp_divqj (qa, jb)
 
3633
    implicit real*8 (d), type (mp_integer) (j), &
 
3634
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3635
    type (mp_real):: mp_divqj
 
3636
    intent (in):: qa, jb
 
3637
    integer mpnw
 
3638
    mpnw = mpnwx
 
3639
    call mpdiv (qa%mpr, jb%mpi, mp_divqj%mpr, mpnw) 
 
3640
    return
 
3641
  end function
 
3642
 
 
3643
  function mp_divqq (qa, qb)
 
3644
    implicit real*8 (d), type (mp_integer) (j), &
 
3645
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3646
    type (mp_real):: mp_divqq
 
3647
    intent (in):: qa, qb
 
3648
    integer mpnw
 
3649
    mpnw = mpnwx
 
3650
    call mpdiv (qa%mpr, qb%mpr, mp_divqq%mpr, mpnw) 
 
3651
    return
 
3652
  end function
 
3653
 
 
3654
  function mp_divqz (qa, zb)
 
3655
    implicit real*8 (d), type (mp_integer) (j), &
 
3656
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3657
    type (mp_complex):: mp_divqz
 
3658
    intent (in):: qa, zb
 
3659
    type (mp_complex) z1
 
3660
    integer mpnw
 
3661
    mpnw = mpnwx
 
3662
    call mpmzc (qa%mpr, z1%mpc)
 
3663
    call mpcdiv (mp4, z1%mpc, zb%mpc, mp_divqz%mpc, mpnw) 
 
3664
    return
 
3665
  end function
 
3666
 
 
3667
  function mp_diviq (ia, qb)
 
3668
    implicit real*8 (d), type (mp_integer) (j), &
 
3669
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3670
    type (mp_real):: mp_diviq
 
3671
    intent (in):: ia, qb
 
3672
    type (mp_real) q1
 
3673
    integer mpnw
 
3674
    mpnw = mpnwx
 
3675
    da = ia
 
3676
    call mpdmc (da, 0, q1%mpr)
 
3677
    call mpdiv (q1%mpr, qb%mpr, mp_diviq%mpr, mpnw) 
 
3678
    return
 
3679
  end function
 
3680
 
 
3681
  function mp_divqi (qa, ib)
 
3682
    implicit real*8 (d), type (mp_integer) (j), &
 
3683
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3684
    type (mp_real):: mp_divqi
 
3685
    intent (in):: qa, ib
 
3686
    integer mpnw
 
3687
    mpnw = mpnwx
 
3688
    db = ib
 
3689
    call mpdivd (qa%mpr, db, 0, mp_divqi%mpr, mpnw) 
 
3690
    return
 
3691
  end function
 
3692
 
 
3693
  function mp_divdq (da, qb)
 
3694
    implicit real*8 (d), type (mp_integer) (j), &
 
3695
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3696
    type (mp_real):: mp_divdq
 
3697
    intent (in):: da, qb
 
3698
    type (mp_real) q1
 
3699
    integer mpnw
 
3700
    mpnw = mpnwx
 
3701
    call mpdmc (da, 0, q1%mpr)
 
3702
    call mpdiv (q1%mpr, qb%mpr, mp_divdq%mpr, mpnw) 
 
3703
    return
 
3704
  end function
 
3705
 
 
3706
  function mp_divqd (qa, db)
 
3707
    implicit real*8 (d), type (mp_integer) (j), &
 
3708
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3709
    type (mp_real):: mp_divqd
 
3710
    intent (in):: qa, db
 
3711
    integer mpnw
 
3712
    mpnw = mpnwx
 
3713
    call mpdivd (qa%mpr, db, 0, mp_divqd%mpr, mpnw) 
 
3714
    return
 
3715
  end function
 
3716
 
 
3717
  function mp_divxq (xa, qb)
 
3718
    implicit real*8 (d), type (mp_integer) (j), &
 
3719
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3720
    type (mp_complex):: mp_divxq
 
3721
    intent (in):: xa, qb
 
3722
    type (mp_complex) z1, z2
 
3723
    integer mpnw
 
3724
    mpnw = mpnwx
 
3725
    call mpxzc (xa, z1%mpc)
 
3726
    call mpmzc (qb%mpr, z2%mpc)
 
3727
    call mpcdiv (mp4, z1%mpc, z2%mpc, mp_divxq%mpc, mpnw) 
 
3728
    return
 
3729
  end function
 
3730
 
 
3731
  function mp_divqx (qa, xb)
 
3732
    implicit real*8 (d), type (mp_integer) (j), &
 
3733
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3734
    type (mp_complex):: mp_divqx
 
3735
    intent (in):: qa, xb
 
3736
    type (mp_complex) z1, z2
 
3737
    integer mpnw
 
3738
    mpnw = mpnwx
 
3739
    call mpmzc (qa%mpr, z1%mpc)
 
3740
    call mpxzc (xb, z2%mpc)
 
3741
    call mpcdiv (mp4, z1%mpc, z2%mpc, mp_divqx%mpc, mpnw) 
 
3742
    return
 
3743
  end function
 
3744
 
 
3745
!  MPR exponentiation routines.
 
3746
 
 
3747
  function mp_expqj (qa, jb)
 
3748
    implicit real*8 (d), type (mp_integer) (j), &
 
3749
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3750
    type (mp_real):: mp_expqj
 
3751
    intent (in):: qa, jb
 
3752
    type (mp_real) q1, q2
 
3753
    integer mpnw
 
3754
    mpnw = mpnwx
 
3755
    call mplog (qa%mpr, mpl02%mpr, q1%mpr, mpnw) 
 
3756
    call mpmul (q1%mpr, jb%mpi, q2%mpr, mpnw) 
 
3757
    call mpexp (q2%mpr, mpl02%mpr, mp_expqj%mpr, mpnw) 
 
3758
    return
 
3759
  end function
 
3760
 
 
3761
  function mp_expqq (qa, qb)
 
3762
    implicit real*8 (d), type (mp_integer) (j), &
 
3763
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3764
    type (mp_real):: mp_expqq
 
3765
    intent (in):: qa, qb
 
3766
    type (mp_real) q1, q2
 
3767
    integer mpnw
 
3768
    mpnw = mpnwx
 
3769
    call mplog (qa%mpr, mpl02%mpr, q1%mpr, mpnw) 
 
3770
    call mpmul (q1%mpr, qb%mpr, q2%mpr, mpnw) 
 
3771
    call mpexp (q2%mpr, mpl02%mpr, mp_expqq%mpr, mpnw) 
 
3772
    return
 
3773
  end function
 
3774
 
 
3775
  function mp_expiq (ia, qb)
 
3776
    implicit real*8 (d), type (mp_integer) (j), &
 
3777
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3778
    type (mp_real):: mp_expiq
 
3779
    intent (in):: ia, qb
 
3780
    type (mp_real) q1, q2, q3
 
3781
    integer mpnw
 
3782
    mpnw = mpnwx
 
3783
    da = ia
 
3784
    call mpdmc (da, 0, q1%mpr)
 
3785
    call mplog (q1%mpr, mpl02%mpr, q2%mpr, mpnw) 
 
3786
    call mpmul (q2%mpr, qb%mpr, q3%mpr, mpnw) 
 
3787
    call mpexp (q3%mpr, mpl02%mpr, mp_expiq%mpr, mpnw) 
 
3788
    return
 
3789
  end function
 
3790
 
 
3791
  function mp_expqi (qa, ib)
 
3792
    implicit real*8 (d), type (mp_integer) (j), &
 
3793
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3794
    type (mp_real):: mp_expqi
 
3795
    intent (in):: qa, ib
 
3796
    integer mpnw
 
3797
    mpnw = mpnwx
 
3798
    call mpnpwr (qa%mpr, ib, mp_expqi%mpr, mpnw) 
 
3799
    return
 
3800
  end function
 
3801
 
 
3802
  function mp_expdq (da, qb)
 
3803
    implicit real*8 (d), type (mp_integer) (j), &
 
3804
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3805
    type (mp_real):: mp_expdq
 
3806
    intent (in):: da, qb
 
3807
    type (mp_real) q1, q2, q3
 
3808
    integer mpnw
 
3809
    mpnw = mpnwx
 
3810
    call mpdmc (da, 0, q1%mpr)
 
3811
    call mplog (q1%mpr, mpl02%mpr, q2%mpr, mpnw) 
 
3812
    call mpmul (q2%mpr, qb%mpr, q3%mpr, mpnw) 
 
3813
    call mpexp (q3%mpr, mpl02%mpr, mp_expdq%mpr, mpnw) 
 
3814
    return
 
3815
    end function
 
3816
 
 
3817
  function mp_expqd (qa, db)
 
3818
    implicit real*8 (d), type (mp_integer) (j), &
 
3819
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3820
    type (mp_real):: mp_expqd
 
3821
    intent (in):: qa, db
 
3822
    type (mp_real) q1, q2
 
3823
    integer mpnw
 
3824
    mpnw = mpnwx
 
3825
    call mplog (qa%mpr, mpl02%mpr, q1%mpr, mpnw) 
 
3826
    call mpmuld (q1%mpr, db, 0, q2%mpr, mpnw) 
 
3827
    call mpexp (q2%mpr, mpl02%mpr, mp_expqd%mpr, mpnw) 
 
3828
    return
 
3829
  end function
 
3830
 
 
3831
!  MPR .EQ. routines.
 
3832
 
 
3833
  function mp_eqtqj (qa, jb)
 
3834
    implicit real*8 (d), type (mp_integer) (j), &
 
3835
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3836
    logical mp_eqtqj
 
3837
    intent (in):: qa, jb
 
3838
    integer mpnw
 
3839
    mpnw = mpnwx
 
3840
    call mpcpr (qa%mpr, jb%mpi, ic, mpnw) 
 
3841
    if (ic .eq. 0) then
 
3842
      mp_eqtqj = .true.
 
3843
    else
 
3844
      mp_eqtqj = .false.
 
3845
    endif
 
3846
    return
 
3847
  end function
 
3848
 
 
3849
  function mp_eqtqq (qa, qb)
 
3850
    implicit real*8 (d), type (mp_integer) (j), &
 
3851
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3852
    logical mp_eqtqq
 
3853
    intent (in):: qa, qb
 
3854
    integer mpnw
 
3855
    mpnw = mpnwx
 
3856
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
3857
    if (ic .eq. 0) then
 
3858
      mp_eqtqq = .true.
 
3859
    else
 
3860
      mp_eqtqq = .false.
 
3861
    endif
 
3862
    return
 
3863
  end function
 
3864
 
 
3865
  function mp_eqtqz (qa, zb)
 
3866
    implicit real*8 (d), type (mp_integer) (j), &
 
3867
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3868
    logical mp_eqtqz
 
3869
    intent (in):: qa, zb
 
3870
    type (mp_complex) z1
 
3871
    integer mpnw
 
3872
    mpnw = mpnwx
 
3873
    call mpmzc (qa%mpr, z1%mpc)
 
3874
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
3875
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
3876
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
3877
      mp_eqtqz = .true.
 
3878
    else
 
3879
      mp_eqtqz = .false.
 
3880
    endif
 
3881
    return
 
3882
  end function
 
3883
 
 
3884
  function mp_eqtiq (ia, qb)
 
3885
    implicit real*8 (d), type (mp_integer) (j), &
 
3886
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3887
    logical mp_eqtiq
 
3888
    intent (in):: ia, qb
 
3889
    type (mp_real) q1
 
3890
    integer mpnw
 
3891
    mpnw = mpnwx
 
3892
    da = ia
 
3893
    call mpdmc (da, 0, q1%mpr)
 
3894
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
3895
    if (ic .eq. 0) then
 
3896
      mp_eqtiq = .true.
 
3897
    else
 
3898
      mp_eqtiq = .false.
 
3899
    endif
 
3900
    return
 
3901
  end function
 
3902
 
 
3903
  function mp_eqtqi (qa, ib)
 
3904
    implicit real*8 (d), type (mp_integer) (j), &
 
3905
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3906
    logical mp_eqtqi
 
3907
    intent (in):: qa, ib
 
3908
    type (mp_real) q1
 
3909
    integer mpnw
 
3910
    mpnw = mpnwx
 
3911
    db = ib
 
3912
    call mpdmc (db, 0, q1%mpr)
 
3913
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
3914
    if (ic .eq. 0) then
 
3915
      mp_eqtqi = .true.
 
3916
    else
 
3917
      mp_eqtqi = .false.
 
3918
    endif
 
3919
    return
 
3920
  end function
 
3921
 
 
3922
  function mp_eqtdq (da, qb)
 
3923
    implicit real*8 (d), type (mp_integer) (j), &
 
3924
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3925
    logical mp_eqtdq
 
3926
    intent (in):: da, qb
 
3927
    type (mp_real) q1
 
3928
    integer mpnw
 
3929
    mpnw = mpnwx
 
3930
    call mpdmc (da, 0, q1%mpr)
 
3931
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
3932
    if (ic .eq. 0) then
 
3933
      mp_eqtdq = .true.
 
3934
    else
 
3935
      mp_eqtdq = .false.
 
3936
    endif
 
3937
    return
 
3938
  end function
 
3939
 
 
3940
  function mp_eqtqd (qa, db)
 
3941
    implicit real*8 (d), type (mp_integer) (j), &
 
3942
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3943
    logical mp_eqtqd
 
3944
    intent (in):: qa, db
 
3945
    type (mp_real) q1
 
3946
    integer mpnw
 
3947
    mpnw = mpnwx
 
3948
    call mpdmc (db, 0, q1%mpr)
 
3949
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
3950
    if (ic .eq. 0) then
 
3951
      mp_eqtqd = .true.
 
3952
    else
 
3953
      mp_eqtqd = .false.
 
3954
    endif
 
3955
    return
 
3956
  end function
 
3957
 
 
3958
  function mp_eqtxq (xa, qb)
 
3959
    implicit real*8 (d), type (mp_integer) (j), &
 
3960
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3961
    logical mp_eqtxq
 
3962
    intent (in):: xa, qb
 
3963
    type (mp_complex) z1, z2
 
3964
    integer mpnw
 
3965
    mpnw = mpnwx
 
3966
    call mpxzc (xa, z1%mpc)
 
3967
    call mpmzc (qb%mpr, z2%mpc)
 
3968
    call mpcpr (z1%mpc, z2%mpc, ic1, mpnw) 
 
3969
    call mpcpr (z1%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
3970
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
3971
      mp_eqtxq = .true.
 
3972
    else
 
3973
      mp_eqtxq = .false.
 
3974
    endif
 
3975
    return
 
3976
  end function
 
3977
 
 
3978
  function mp_eqtqx (qa, xb)
 
3979
    implicit real*8 (d), type (mp_integer) (j), &
 
3980
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
3981
    logical mp_eqtqx
 
3982
    intent (in):: qa, xb
 
3983
    type (mp_complex) z1, z2
 
3984
    integer mpnw
 
3985
    mpnw = mpnwx
 
3986
    call mpmzc (qa%mpr, z1%mpc)
 
3987
    call mpxzc (xb, z2%mpc)
 
3988
    call mpcpr (z1%mpc, z2%mpc, ic1, mpnw) 
 
3989
    call mpcpr (z1%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
3990
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
3991
      mp_eqtqx = .true.
 
3992
    else
 
3993
      mp_eqtqx = .false.
 
3994
    endif
 
3995
    return
 
3996
  end function
 
3997
 
 
3998
!  MPR .NE. routines.
 
3999
 
 
4000
  function mp_netqj (qa, jb)
 
4001
    implicit real*8 (d), type (mp_integer) (j), &
 
4002
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4003
    logical mp_netqj
 
4004
    intent (in):: qa, jb
 
4005
    integer mpnw
 
4006
    mpnw = mpnwx
 
4007
    call mpcpr (qa%mpr, jb%mpi, ic, mpnw) 
 
4008
    if (ic .ne. 0) then
 
4009
      mp_netqj = .true.
 
4010
    else
 
4011
      mp_netqj = .false.
 
4012
    endif
 
4013
    return
 
4014
  end function
 
4015
 
 
4016
  function mp_netqq (qa, qb)
 
4017
    implicit real*8 (d), type (mp_integer) (j), &
 
4018
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4019
    logical mp_netqq
 
4020
    intent (in):: qa, qb
 
4021
    integer mpnw
 
4022
    mpnw = mpnwx
 
4023
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
4024
    if (ic .ne. 0) then
 
4025
      mp_netqq = .true.
 
4026
    else
 
4027
      mp_netqq = .false.
 
4028
    endif
 
4029
    return
 
4030
  end function
 
4031
 
 
4032
  function mp_netqz (qa, zb)
 
4033
    implicit real*8 (d), type (mp_integer) (j), &
 
4034
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4035
    logical mp_netqz
 
4036
    intent (in):: qa, zb
 
4037
    type (mp_complex) z1
 
4038
    integer mpnw
 
4039
    mpnw = mpnwx
 
4040
    call mpmzc (qa%mpr, z1%mpc)
 
4041
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
4042
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
4043
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
4044
      mp_netqz = .true.
 
4045
    else
 
4046
      mp_netqz = .false.
 
4047
    endif
 
4048
    return
 
4049
  end function
 
4050
 
 
4051
  function mp_netiq (ia, qb)
 
4052
    implicit real*8 (d), type (mp_integer) (j), &
 
4053
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4054
    logical mp_netiq
 
4055
    intent (in):: ia, qb
 
4056
    type (mp_real) q1
 
4057
    integer mpnw
 
4058
    mpnw = mpnwx
 
4059
    da = ia
 
4060
    call mpdmc (da, 0, q1%mpr)
 
4061
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4062
    if (ic .ne. 0) then
 
4063
      mp_netiq = .true.
 
4064
    else
 
4065
      mp_netiq = .false.
 
4066
    endif
 
4067
    return
 
4068
  end function
 
4069
 
 
4070
  function mp_netqi (qa, ib)
 
4071
    implicit real*8 (d), type (mp_integer) (j), &
 
4072
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4073
    logical mp_netqi
 
4074
    intent (in):: qa, ib
 
4075
    type (mp_real) q1
 
4076
    integer mpnw
 
4077
    mpnw = mpnwx
 
4078
    db = ib
 
4079
    call mpdmc (db, 0, q1%mpr)
 
4080
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4081
    if (ic .ne. 0) then
 
4082
      mp_netqi = .true.
 
4083
    else
 
4084
      mp_netqi = .false.
 
4085
    endif
 
4086
    return
 
4087
  end function
 
4088
 
 
4089
  function mp_netdq (da, qb)
 
4090
    implicit real*8 (d), type (mp_integer) (j), &
 
4091
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4092
    logical mp_netdq
 
4093
    intent (in):: da, qb
 
4094
    type (mp_real) q1
 
4095
    integer mpnw
 
4096
    mpnw = mpnwx
 
4097
    call mpdmc (da, 0, q1%mpr)
 
4098
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4099
    if (ic .ne. 0) then
 
4100
      mp_netdq = .true.
 
4101
    else
 
4102
      mp_netdq = .false.
 
4103
    endif
 
4104
    return
 
4105
  end function
 
4106
 
 
4107
  function mp_netqd (qa, db)
 
4108
    implicit real*8 (d), type (mp_integer) (j), &
 
4109
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4110
    logical mp_netqd
 
4111
    intent (in):: qa, db
 
4112
    type (mp_real) q1
 
4113
    integer mpnw
 
4114
    mpnw = mpnwx
 
4115
    call mpdmc (db, 0, q1%mpr)
 
4116
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4117
    if (ic .ne. 0) then
 
4118
      mp_netqd = .true.
 
4119
    else
 
4120
      mp_netqd = .false.
 
4121
    endif
 
4122
    return
 
4123
  end function
 
4124
 
 
4125
  function mp_netxq (xa, qb)
 
4126
    implicit real*8 (d), type (mp_integer) (j), &
 
4127
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4128
    logical mp_netxq
 
4129
    intent (in):: xa, qb
 
4130
    type (mp_complex) z1, z2
 
4131
    integer mpnw
 
4132
    mpnw = mpnwx
 
4133
    call mpxzc (xa, z1%mpc)
 
4134
    call mpmzc (qb%mpr, z2%mpc)
 
4135
    call mpcpr (z1%mpc, z2%mpc, ic1, mpnw) 
 
4136
    call mpcpr (z1%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
4137
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
4138
      mp_netxq = .true.
 
4139
    else
 
4140
      mp_netxq = .false.
 
4141
    endif
 
4142
    return
 
4143
  end function
 
4144
 
 
4145
  function mp_netqx (qa, xb)
 
4146
    implicit real*8 (d), type (mp_integer) (j), &
 
4147
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4148
    logical mp_netqx
 
4149
    intent (in):: qa, xb
 
4150
    type (mp_complex) z1, z2
 
4151
    integer mpnw
 
4152
    mpnw = mpnwx
 
4153
    call mpmzc (qa%mpr, z1%mpc)
 
4154
    call mpxzc (xb, z2%mpc)
 
4155
    call mpcpr (z1%mpc, z2%mpc, ic1, mpnw) 
 
4156
    call mpcpr (z1%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
4157
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
4158
      mp_netqx = .true.
 
4159
    else
 
4160
      mp_netqx = .false.
 
4161
    endif
 
4162
    return
 
4163
  end function
 
4164
 
 
4165
!  MPR .LE. routines.
 
4166
 
 
4167
  function mp_letqj (qa, jb)
 
4168
    implicit real*8 (d), type (mp_integer) (j), &
 
4169
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4170
    logical mp_letqj
 
4171
    intent (in):: qa, jb
 
4172
    integer mpnw
 
4173
    mpnw = mpnwx
 
4174
    call mpcpr (qa%mpr, jb%mpi, ic, mpnw) 
 
4175
    if (ic .le. 0) then
 
4176
      mp_letqj = .true.
 
4177
    else
 
4178
      mp_letqj = .false.
 
4179
    endif
 
4180
    return
 
4181
  end function
 
4182
 
 
4183
  function mp_letqq (qa, qb)
 
4184
    implicit real*8 (d), type (mp_integer) (j), &
 
4185
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4186
    logical mp_letqq
 
4187
    intent (in):: qa, qb
 
4188
    integer mpnw
 
4189
    mpnw = mpnwx
 
4190
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
4191
    if (ic .le. 0) then
 
4192
      mp_letqq = .true.
 
4193
    else
 
4194
      mp_letqq = .false.
 
4195
    endif
 
4196
    return
 
4197
  end function
 
4198
 
 
4199
  function mp_letiq (ia, qb)
 
4200
    implicit real*8 (d), type (mp_integer) (j), &
 
4201
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4202
    logical mp_letiq
 
4203
    intent (in):: ia, qb
 
4204
    type (mp_real) q1
 
4205
    integer mpnw
 
4206
    mpnw = mpnwx
 
4207
    da = ia
 
4208
    call mpdmc (da, 0, q1%mpr)
 
4209
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4210
    if (ic .le. 0) then
 
4211
      mp_letiq = .true.
 
4212
    else
 
4213
      mp_letiq = .false.
 
4214
    endif
 
4215
    return
 
4216
  end function
 
4217
 
 
4218
  function mp_letqi (qa, ib)
 
4219
    implicit real*8 (d), type (mp_integer) (j), &
 
4220
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4221
    logical mp_letqi
 
4222
    intent (in):: qa, ib
 
4223
    type (mp_real) q1
 
4224
    integer mpnw
 
4225
    mpnw = mpnwx
 
4226
    db = ib
 
4227
    call mpdmc (db, 0, q1%mpr)
 
4228
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4229
    if (ic .le. 0) then
 
4230
      mp_letqi = .true.
 
4231
    else
 
4232
      mp_letqi = .false.
 
4233
    endif
 
4234
    return
 
4235
  end function
 
4236
 
 
4237
  function mp_letdq (da, qb)
 
4238
    implicit real*8 (d), type (mp_integer) (j), &
 
4239
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4240
    logical mp_letdq
 
4241
    intent (in):: da, qb
 
4242
    type (mp_real) q1
 
4243
    integer mpnw
 
4244
    mpnw = mpnwx
 
4245
    call mpdmc (da, 0, q1%mpr)
 
4246
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4247
    if (ic .le. 0) then
 
4248
      mp_letdq = .true.
 
4249
    else
 
4250
      mp_letdq = .false.
 
4251
    endif
 
4252
    return
 
4253
  end function
 
4254
 
 
4255
  function mp_letqd (qa, db)
 
4256
    implicit real*8 (d), type (mp_integer) (j), &
 
4257
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4258
    logical mp_letqd
 
4259
    intent (in):: qa, db
 
4260
    type (mp_real) q1
 
4261
    integer mpnw
 
4262
    mpnw = mpnwx
 
4263
    call mpdmc (db, 0, q1%mpr)
 
4264
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4265
    if (ic .le. 0) then
 
4266
      mp_letqd = .true.
 
4267
    else
 
4268
      mp_letqd = .false.
 
4269
    endif
 
4270
    return
 
4271
  end function
 
4272
 
 
4273
!  MPR .GE. routines.
 
4274
 
 
4275
  function mp_getqj (qa, jb)
 
4276
    implicit real*8 (d), type (mp_integer) (j), &
 
4277
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4278
    logical mp_getqj
 
4279
    intent (in):: qa, jb
 
4280
    integer mpnw
 
4281
    mpnw = mpnwx
 
4282
    call mpcpr (qa%mpr, jb%mpi, ic, mpnw) 
 
4283
    if (ic .ge. 0) then
 
4284
      mp_getqj = .true.
 
4285
    else
 
4286
      mp_getqj = .false.
 
4287
    endif
 
4288
    return
 
4289
  end function
 
4290
 
 
4291
  function mp_getqq (qa, qb)
 
4292
    implicit real*8 (d), type (mp_integer) (j), &
 
4293
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4294
    logical mp_getqq
 
4295
    intent (in):: qa, qb
 
4296
    integer mpnw
 
4297
    mpnw = mpnwx
 
4298
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
4299
    if (ic .ge. 0) then
 
4300
      mp_getqq = .true.
 
4301
    else
 
4302
      mp_getqq = .false.
 
4303
    endif
 
4304
    return
 
4305
  end function
 
4306
 
 
4307
  function mp_getiq (ia, qb)
 
4308
    implicit real*8 (d), type (mp_integer) (j), &
 
4309
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4310
    logical mp_getiq
 
4311
    intent (in):: ia, qb
 
4312
    type (mp_real) q1
 
4313
    integer mpnw
 
4314
    mpnw = mpnwx
 
4315
    da = ia
 
4316
    call mpdmc (da, 0, q1%mpr)
 
4317
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4318
    if (ic .ge. 0) then
 
4319
      mp_getiq = .true.
 
4320
    else
 
4321
      mp_getiq = .false.
 
4322
    endif
 
4323
    return
 
4324
  end function
 
4325
 
 
4326
  function mp_getqi (qa, ib)
 
4327
    implicit real*8 (d), type (mp_integer) (j), &
 
4328
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4329
    logical mp_getqi
 
4330
    intent (in):: qa, ib
 
4331
    type (mp_real) q1
 
4332
    integer mpnw
 
4333
    mpnw = mpnwx
 
4334
    db = ib
 
4335
    call mpdmc (db, 0, q1%mpr)
 
4336
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4337
    if (ic .ge. 0) then
 
4338
      mp_getqi = .true.
 
4339
    else
 
4340
      mp_getqi = .false.
 
4341
    endif
 
4342
    return
 
4343
  end function
 
4344
 
 
4345
  function mp_getdq (da, qb)
 
4346
    implicit real*8 (d), type (mp_integer) (j), &
 
4347
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4348
    logical mp_getdq
 
4349
    intent (in):: da, qb
 
4350
    type (mp_real) q1
 
4351
    integer mpnw
 
4352
    mpnw = mpnwx
 
4353
    call mpdmc (da, 0, q1%mpr)
 
4354
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4355
    if (ic .ge. 0) then
 
4356
      mp_getdq = .true.
 
4357
    else
 
4358
      mp_getdq = .false.
 
4359
    endif
 
4360
    return
 
4361
  end function
 
4362
 
 
4363
  function mp_getqd (qa, db)
 
4364
    implicit real*8 (d), type (mp_integer) (j), &
 
4365
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4366
    logical mp_getqd
 
4367
    intent (in):: qa, db
 
4368
    type (mp_real) q1
 
4369
    integer mpnw
 
4370
    mpnw = mpnwx
 
4371
    call mpdmc (db, 0, q1%mpr)
 
4372
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4373
    if (ic .ge. 0) then
 
4374
      mp_getqd = .true.
 
4375
    else
 
4376
      mp_getqd = .false.
 
4377
    endif
 
4378
    return
 
4379
  end function
 
4380
 
 
4381
!  MPR .LT. routines.
 
4382
 
 
4383
  function mp_lttqj (qa, jb)
 
4384
    implicit real*8 (d), type (mp_integer) (j), &
 
4385
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4386
    logical mp_lttqj
 
4387
    intent (in):: qa, jb
 
4388
    integer mpnw
 
4389
    mpnw = mpnwx
 
4390
    call mpcpr (qa%mpr, jb%mpi, ic, mpnw) 
 
4391
    if (ic .lt. 0) then
 
4392
      mp_lttqj = .true.
 
4393
    else
 
4394
      mp_lttqj = .false.
 
4395
    endif
 
4396
    return
 
4397
  end function
 
4398
 
 
4399
  function mp_lttqq (qa, qb)
 
4400
    implicit real*8 (d), type (mp_integer) (j), &
 
4401
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4402
    logical mp_lttqq
 
4403
    intent (in):: qa, qb
 
4404
    integer mpnw
 
4405
    mpnw = mpnwx
 
4406
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
4407
    if (ic .lt. 0) then
 
4408
      mp_lttqq = .true.
 
4409
    else
 
4410
      mp_lttqq = .false.
 
4411
    endif
 
4412
    return
 
4413
  end function
 
4414
 
 
4415
  function mp_lttiq (ia, qb)
 
4416
    implicit real*8 (d), type (mp_integer) (j), &
 
4417
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4418
    logical mp_lttiq
 
4419
    intent (in):: ia, qb
 
4420
    type (mp_real) q1
 
4421
    integer mpnw
 
4422
    mpnw = mpnwx
 
4423
    da = ia
 
4424
    call mpdmc (da, 0, q1%mpr)
 
4425
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4426
    if (ic .lt. 0) then
 
4427
      mp_lttiq = .true.
 
4428
    else
 
4429
      mp_lttiq = .false.
 
4430
    endif
 
4431
    return
 
4432
  end function
 
4433
 
 
4434
  function mp_lttqi (qa, ib)
 
4435
    implicit real*8 (d), type (mp_integer) (j), &
 
4436
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4437
    logical mp_lttqi
 
4438
    intent (in):: qa, ib
 
4439
    type (mp_real) q1
 
4440
    integer mpnw
 
4441
    mpnw = mpnwx
 
4442
    db = ib
 
4443
    call mpdmc (db, 0, q1%mpr)
 
4444
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4445
    if (ic .lt. 0) then
 
4446
      mp_lttqi = .true.
 
4447
    else
 
4448
      mp_lttqi = .false.
 
4449
    endif
 
4450
    return
 
4451
  end function
 
4452
 
 
4453
  function mp_lttdq (da, qb)
 
4454
    implicit real*8 (d), type (mp_integer) (j), &
 
4455
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4456
    logical mp_lttdq
 
4457
    intent (in):: da, qb
 
4458
    type (mp_real) q1
 
4459
    integer mpnw
 
4460
    mpnw = mpnwx
 
4461
    call mpdmc (da, 0, q1%mpr)
 
4462
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4463
    if (ic .lt. 0) then
 
4464
      mp_lttdq = .true.
 
4465
    else
 
4466
      mp_lttdq = .false.
 
4467
    endif
 
4468
    return
 
4469
  end function
 
4470
 
 
4471
  function mp_lttqd (qa, db)
 
4472
    implicit real*8 (d), type (mp_integer) (j), &
 
4473
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4474
    logical mp_lttqd
 
4475
    intent (in):: qa, db
 
4476
    type (mp_real) q1
 
4477
    integer mpnw
 
4478
    mpnw = mpnwx
 
4479
    call mpdmc (db, 0, q1%mpr)
 
4480
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4481
    if (ic .lt. 0) then
 
4482
      mp_lttqd = .true.
 
4483
    else
 
4484
      mp_lttqd = .false.
 
4485
    endif
 
4486
    return
 
4487
  end function
 
4488
 
 
4489
!  MPR .GT. routines.
 
4490
 
 
4491
  function mp_gttqj (qa, jb)
 
4492
    implicit real*8 (d), type (mp_integer) (j), &
 
4493
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4494
    logical mp_gttqj
 
4495
    intent (in):: qa, jb
 
4496
    integer mpnw
 
4497
    mpnw = mpnwx
 
4498
    call mpcpr (qa%mpr, jb%mpi, ic, mpnw) 
 
4499
    if (ic .gt. 0) then
 
4500
      mp_gttqj = .true.
 
4501
    else
 
4502
      mp_gttqj = .false.
 
4503
    endif
 
4504
    return
 
4505
  end function
 
4506
 
 
4507
  function mp_gttqq (qa, qb)
 
4508
    implicit real*8 (d), type (mp_integer) (j), &
 
4509
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4510
    logical mp_gttqq
 
4511
    intent (in):: qa, qb
 
4512
    integer mpnw
 
4513
    mpnw = mpnwx
 
4514
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
4515
    if (ic .gt. 0) then
 
4516
      mp_gttqq = .true.
 
4517
    else
 
4518
      mp_gttqq = .false.
 
4519
    endif
 
4520
    return
 
4521
  end function
 
4522
 
 
4523
  function mp_gttiq (ia, qb)
 
4524
    implicit real*8 (d), type (mp_integer) (j), &
 
4525
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4526
    logical mp_gttiq
 
4527
    intent (in):: ia, qb
 
4528
    type (mp_real) q1
 
4529
    integer mpnw
 
4530
    mpnw = mpnwx
 
4531
    da = ia
 
4532
    call mpdmc (da, 0, q1%mpr)
 
4533
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4534
    if (ic .gt. 0) then
 
4535
      mp_gttiq = .true.
 
4536
    else
 
4537
      mp_gttiq = .false.
 
4538
    endif
 
4539
    return
 
4540
  end function
 
4541
 
 
4542
  function mp_gttqi (qa, ib)
 
4543
    implicit real*8 (d), type (mp_integer) (j), &
 
4544
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4545
    logical mp_gttqi
 
4546
    intent (in):: qa, ib
 
4547
    type (mp_real) q1
 
4548
    integer mpnw
 
4549
    mpnw = mpnwx
 
4550
    db = ib
 
4551
    call mpdmc (db, 0, q1%mpr)
 
4552
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4553
    if (ic .gt. 0) then
 
4554
      mp_gttqi = .true.
 
4555
    else
 
4556
      mp_gttqi = .false.
 
4557
    endif
 
4558
    return
 
4559
  end function
 
4560
 
 
4561
  function mp_gttdq (da, qb)
 
4562
    implicit real*8 (d), type (mp_integer) (j), &
 
4563
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4564
    logical mp_gttdq
 
4565
    intent (in):: da, qb
 
4566
    type (mp_real) q1
 
4567
    integer mpnw
 
4568
    mpnw = mpnwx
 
4569
    call mpdmc (da, 0, q1%mpr)
 
4570
    call mpcpr (q1%mpr, qb%mpr, ic, mpnw) 
 
4571
    if (ic .gt. 0) then
 
4572
      mp_gttdq = .true.
 
4573
    else
 
4574
      mp_gttdq = .false.
 
4575
    endif
 
4576
    return
 
4577
  end function
 
4578
 
 
4579
  function mp_gttqd (qa, db)
 
4580
    implicit real*8 (d), type (mp_integer) (j), &
 
4581
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4582
    logical mp_gttqd
 
4583
    intent (in):: qa, db
 
4584
    type (mp_real) q1
 
4585
    integer mpnw
 
4586
    mpnw = mpnwx
 
4587
    call mpdmc (db, 0, q1%mpr)
 
4588
    call mpcpr (qa%mpr, q1%mpr, ic, mpnw) 
 
4589
    if (ic .gt. 0) then
 
4590
      mp_gttqd = .true.
 
4591
    else
 
4592
      mp_gttqd = .false.
 
4593
    endif
 
4594
    return
 
4595
  end function
 
4596
 
 
4597
end module
 
4598
 
 
4599
 
 
4600
module mpcmpmod
 
4601
 
 
4602
!  This Fortran-90 module defines operator extensions involving the
 
4603
!  MP_COMPLEX datatype.  For operations involving two MP data types,
 
4604
!  those whose first argument is MP_COMPLEX are included here.
 
4605
!  Others are handled in other modules.
 
4606
 
 
4607
!  The subroutines and functions defined in this module are private
 
4608
!  and not intended to be called directly by the user.
 
4609
 
 
4610
use mpfunmod
 
4611
use mpdefmod
 
4612
private kdb, mp4, mp24, mp41
 
4613
parameter (kdb = kind (0.d0), mp4 = mpwds + 4, mp24 = 2 * mp4, mp41 = mp4 + 1)
 
4614
private &
 
4615
  mp_eqzj, mp_eqzq, mp_eqzz, mp_eqiz, mp_eqzi, &
 
4616
  mp_eqdz, mp_eqzd, mp_eqxz, mp_eqzx, &
 
4617
  mp_addzj, mp_addzq, mp_addzz, mp_addiz, mp_addzi, &
 
4618
  mp_adddz, mp_addzd, mp_addxz, mp_addzx, &
 
4619
  mp_subzj, mp_subzq, mp_subzz, mp_subiz, mp_subzi, &
 
4620
  mp_subdz, mp_subzd, mp_subxz, mp_subzx, mp_negz, &
 
4621
  mp_mulzj, mp_mulzq, mp_mulzz, mp_muliz, mp_mulzi, &
 
4622
  mp_muldz, mp_mulzd, mp_mulxz, mp_mulzx, &
 
4623
  mp_divzj, mp_divzq, mp_divzz, mp_diviz, mp_divzi, &
 
4624
  mp_divdz, mp_divzd, mp_divxz, mp_divzx, mp_expzi, &
 
4625
  mp_eqtzj, mp_eqtzq, mp_eqtzz, mp_eqtiz, mp_eqtzi, &
 
4626
  mp_eqtdz, mp_eqtzd, mp_eqtxz, mp_eqtzx, &
 
4627
  mp_netzj, mp_netzq, mp_netzz, mp_netiz, mp_netzi, &
 
4628
  mp_netdz, mp_netzd, mp_netxz, mp_netzx
 
4629
 
 
4630
!  MPR operator extension interface blocks.
 
4631
 
 
4632
interface assignment (=)
 
4633
  module procedure mp_eqzj
 
4634
  module procedure mp_eqzq
 
4635
  module procedure mp_eqzz
 
4636
  module procedure mp_eqiz
 
4637
  module procedure mp_eqzi
 
4638
  module procedure mp_eqdz
 
4639
  module procedure mp_eqzd
 
4640
  module procedure mp_eqxz
 
4641
  module procedure mp_eqzx
 
4642
end interface
 
4643
 
 
4644
interface operator (+)
 
4645
  module procedure mp_addzj
 
4646
  module procedure mp_addzq
 
4647
  module procedure mp_addzz
 
4648
  module procedure mp_addiz
 
4649
  module procedure mp_addzi
 
4650
  module procedure mp_adddz
 
4651
  module procedure mp_addzd
 
4652
  module procedure mp_addxz
 
4653
  module procedure mp_addzx
 
4654
end interface
 
4655
 
 
4656
interface operator (-)
 
4657
  module procedure mp_subzj
 
4658
  module procedure mp_subzq
 
4659
  module procedure mp_subzz
 
4660
  module procedure mp_subiz
 
4661
  module procedure mp_subzi
 
4662
  module procedure mp_subdz
 
4663
  module procedure mp_subzd
 
4664
  module procedure mp_subxz
 
4665
  module procedure mp_subzx
 
4666
 
 
4667
  module procedure mp_negz
 
4668
end interface
 
4669
 
 
4670
interface operator (*)
 
4671
  module procedure mp_mulzj
 
4672
  module procedure mp_mulzq
 
4673
  module procedure mp_mulzz
 
4674
  module procedure mp_muliz
 
4675
  module procedure mp_mulzi
 
4676
  module procedure mp_muldz
 
4677
  module procedure mp_mulzd
 
4678
  module procedure mp_mulxz
 
4679
  module procedure mp_mulzx
 
4680
end interface
 
4681
 
 
4682
interface operator (/)
 
4683
  module procedure mp_divzj
 
4684
  module procedure mp_divzq
 
4685
  module procedure mp_divzz
 
4686
  module procedure mp_diviz
 
4687
  module procedure mp_divzi
 
4688
  module procedure mp_divdz
 
4689
  module procedure mp_divzd
 
4690
  module procedure mp_divxz
 
4691
  module procedure mp_divzx
 
4692
end interface
 
4693
 
 
4694
interface operator (**)
 
4695
  module procedure mp_expzi
 
4696
end interface
 
4697
 
 
4698
interface operator (.eq.)
 
4699
  module procedure mp_eqtzj
 
4700
  module procedure mp_eqtzq
 
4701
  module procedure mp_eqtzz
 
4702
  module procedure mp_eqtiz
 
4703
  module procedure mp_eqtzi
 
4704
  module procedure mp_eqtdz
 
4705
  module procedure mp_eqtzd
 
4706
  module procedure mp_eqtxz
 
4707
  module procedure mp_eqtzx
 
4708
end interface
 
4709
 
 
4710
interface operator (.ne.)
 
4711
  module procedure mp_netzj
 
4712
  module procedure mp_netzq
 
4713
  module procedure mp_netzz
 
4714
  module procedure mp_netiz
 
4715
  module procedure mp_netzi
 
4716
  module procedure mp_netdz
 
4717
  module procedure mp_netzd
 
4718
  module procedure mp_netxz
 
4719
  module procedure mp_netzx
 
4720
end interface
 
4721
 
 
4722
contains
 
4723
 
 
4724
!  MPC assignment routines.
 
4725
 
 
4726
  subroutine mp_eqzj (za, jb)
 
4727
    implicit real*8 (d), type (mp_integer) (j), &
 
4728
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4729
    intent (out):: za
 
4730
    intent (in):: jb
 
4731
    call mpmzc (jb%mpi, za%mpc)
 
4732
    return
 
4733
  end subroutine
 
4734
 
 
4735
  subroutine mp_eqzq (za, qb)
 
4736
    implicit real*8 (d), type (mp_integer) (j), &
 
4737
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4738
    intent (out):: za
 
4739
    intent (in):: qb
 
4740
    integer mpnw
 
4741
    mpnw = mpnwx
 
4742
    call mpmzc (qb%mpr, za%mpc)
 
4743
    return
 
4744
  end subroutine
 
4745
 
 
4746
  subroutine mp_eqzz (za, zb)
 
4747
    implicit real*8 (d), type (mp_integer) (j), &
 
4748
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4749
    intent (out):: za
 
4750
    intent (in):: zb
 
4751
    integer mpnw
 
4752
    mpnw = mpnwx
 
4753
    call mpceq (mp4, zb%mpc, za%mpc, mpnw) 
 
4754
    return
 
4755
  end subroutine
 
4756
 
 
4757
  subroutine mp_eqiz (ia, zb)
 
4758
    implicit real*8 (d), type (mp_integer) (j), &
 
4759
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4760
    intent (out):: ia
 
4761
    intent (in):: zb
 
4762
    integer mpnw
 
4763
    mpnw = mpnwx
 
4764
    call mpmdc (zb%mpc, db, ib)
 
4765
    ia = db * 2.d0 ** ib
 
4766
    return
 
4767
  end subroutine
 
4768
 
 
4769
  subroutine mp_eqzi (za, ib)
 
4770
    implicit real*8 (d), type (mp_integer) (j), &
 
4771
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4772
    intent (out):: za
 
4773
    intent (in):: ib
 
4774
    integer mpnw
 
4775
    mpnw = mpnwx
 
4776
    xb = ib
 
4777
    call mpxzc (xb, za%mpc)
 
4778
    return
 
4779
  end subroutine
 
4780
 
 
4781
  subroutine mp_eqdz (da, zb)
 
4782
    implicit real*8 (d), type (mp_integer) (j), &
 
4783
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4784
    intent (out):: da
 
4785
    intent (in):: zb
 
4786
    integer mpnw
 
4787
    mpnw = mpnwx
 
4788
    call mpmdc (zb%mpc, db, ib)
 
4789
    da = db * 2.d0 ** ib
 
4790
    return
 
4791
  end subroutine
 
4792
 
 
4793
  subroutine mp_eqzd (za, db)
 
4794
    implicit real*8 (d), type (mp_integer) (j), &
 
4795
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4796
    intent (out):: za
 
4797
    intent (in):: db
 
4798
    integer mpnw
 
4799
    mpnw = mpnwx
 
4800
    xb = db
 
4801
    call mpxzc (xb, za%mpc)
 
4802
    return
 
4803
  end subroutine
 
4804
 
 
4805
  subroutine mp_eqxz (xa, zb)
 
4806
    implicit real*8 (d), type (mp_integer) (j), &
 
4807
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4808
    intent (out):: xa
 
4809
    intent (in):: zb
 
4810
    integer mpnw
 
4811
    mpnw = mpnwx
 
4812
    call mpmdc (zb%mpc, db, ib)
 
4813
    call mpmdc (zb%mpc(mp41), dc, ic)
 
4814
    xa = cmplx (db * 2.d0 ** ib, dc * 2.d0 ** ic, kdb)
 
4815
    return
 
4816
  end subroutine
 
4817
 
 
4818
  subroutine mp_eqzx (za, xb)
 
4819
    implicit real*8 (d), type (mp_integer) (j), &
 
4820
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4821
    intent (out):: za
 
4822
    intent (in):: xb
 
4823
    integer mpnw
 
4824
    mpnw = mpnwx
 
4825
    call mpxzc (xb, za%mpc)
 
4826
    return
 
4827
  end subroutine
 
4828
 
 
4829
!  MPC add routines.
 
4830
 
 
4831
  function mp_addzj (za, jb)
 
4832
    implicit real*8 (d), type (mp_integer) (j), &
 
4833
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4834
    type (mp_complex):: mp_addzj
 
4835
    intent (in):: za, jb
 
4836
    type (mp_complex) z1
 
4837
    integer mpnw
 
4838
    mpnw = mpnwx
 
4839
    call mpmzc (jb%mpi, z1%mpc)
 
4840
    call mpcadd (mp4, za%mpc, z1%mpc, mp_addzj%mpc, mpnw) 
 
4841
    return
 
4842
  end function
 
4843
 
 
4844
  function mp_addzq (za, qb)
 
4845
    implicit real*8 (d), type (mp_integer) (j), &
 
4846
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4847
    type (mp_complex):: mp_addzq
 
4848
    intent (in):: za, qb
 
4849
    type (mp_complex) z1
 
4850
    integer mpnw
 
4851
    mpnw = mpnwx
 
4852
    call mpmzc (qb%mpr, z1%mpc)
 
4853
    call mpcadd (mp4, za%mpc, z1%mpc, mp_addzq%mpc, mpnw) 
 
4854
    return
 
4855
  end function
 
4856
 
 
4857
  function mp_addzz (za, zb)
 
4858
    implicit real*8 (d), type (mp_integer) (j), &
 
4859
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4860
    type (mp_complex):: mp_addzz
 
4861
    intent (in):: za, zb
 
4862
    integer mpnw
 
4863
    mpnw = mpnwx
 
4864
    call mpcadd (mp4, za%mpc, zb%mpc, mp_addzz%mpc, mpnw) 
 
4865
    return
 
4866
  end function
 
4867
 
 
4868
  function mp_addiz (ia, zb)
 
4869
    implicit real*8 (d), type (mp_integer) (j), &
 
4870
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4871
    type (mp_complex):: mp_addiz
 
4872
    intent (in):: ia, zb
 
4873
    type (mp_complex) z1
 
4874
    integer mpnw
 
4875
    mpnw = mpnwx
 
4876
    xa = ia
 
4877
    call mpxzc (xa, z1%mpc)
 
4878
    call mpcadd (mp4, z1%mpc, zb%mpc, mp_addiz%mpc, mpnw) 
 
4879
    return
 
4880
  end function
 
4881
 
 
4882
  function mp_addzi (za, ib)
 
4883
    implicit real*8 (d), type (mp_integer) (j), &
 
4884
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4885
    type (mp_complex):: mp_addzi
 
4886
    intent (in):: za, ib
 
4887
    type (mp_complex) z1
 
4888
    integer mpnw
 
4889
    mpnw = mpnwx
 
4890
    xb = ib
 
4891
    call mpxzc (xb, z1%mpc)
 
4892
    call mpcadd (mp4, za%mpc, z1%mpc, mp_addzi%mpc, mpnw) 
 
4893
    return
 
4894
  end function
 
4895
 
 
4896
  function mp_adddz (da, zb)
 
4897
    implicit real*8 (d), type (mp_integer) (j), &
 
4898
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4899
    type (mp_complex):: mp_adddz
 
4900
    intent (in):: da, zb
 
4901
    type (mp_complex) z1
 
4902
    integer mpnw
 
4903
    mpnw = mpnwx
 
4904
    xa = da
 
4905
    call mpxzc (xa, z1%mpc)
 
4906
    call mpcadd (mp4, z1%mpc, zb%mpc, mp_adddz%mpc, mpnw) 
 
4907
    return
 
4908
  end function
 
4909
 
 
4910
  function mp_addzd (za, db)
 
4911
    implicit real*8 (d), type (mp_integer) (j), &
 
4912
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4913
    type (mp_complex):: mp_addzd
 
4914
    intent (in):: za, db
 
4915
    type (mp_complex) z1
 
4916
    integer mpnw
 
4917
    mpnw = mpnwx
 
4918
    xb = db
 
4919
    call mpxzc (xb, z1%mpc)
 
4920
    call mpcadd (mp4, za%mpc, z1%mpc, mp_addzd%mpc, mpnw) 
 
4921
    return
 
4922
  end function
 
4923
 
 
4924
  function mp_addxz (xa, zb)
 
4925
    implicit real*8 (d), type (mp_integer) (j), &
 
4926
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4927
    type (mp_complex):: mp_addxz
 
4928
    intent (in):: xa, zb
 
4929
    type (mp_complex) z1
 
4930
    integer mpnw
 
4931
    mpnw = mpnwx
 
4932
    call mpxzc (xa, z1%mpc)
 
4933
    call mpcadd (mp4, z1%mpc, zb%mpc, mp_addxz%mpc, mpnw) 
 
4934
    return
 
4935
  end function
 
4936
 
 
4937
  function mp_addzx (za, xb)
 
4938
    implicit real*8 (d), type (mp_integer) (j), &
 
4939
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4940
    type (mp_complex):: mp_addzx
 
4941
    intent (in):: za, xb
 
4942
    type (mp_complex) q1
 
4943
    integer mpnw
 
4944
    mpnw = mpnwx
 
4945
    call mpxzc (xb, q1%mpc)
 
4946
    call mpcadd (mp4, za%mpc, q1%mpc, mp_addzx%mpc, mpnw) 
 
4947
    return
 
4948
  end function
 
4949
 
 
4950
!  MPC subtract routines.
 
4951
 
 
4952
  function mp_subzj (za, jb)
 
4953
    implicit real*8 (d), type (mp_integer) (j), &
 
4954
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4955
    type (mp_complex):: mp_subzj
 
4956
    intent (in):: za, jb
 
4957
    type (mp_complex) z1
 
4958
    integer mpnw
 
4959
    mpnw = mpnwx
 
4960
    call mpmzc (jb%mpi, z1%mpc)
 
4961
    call mpcsub (mp4, za%mpc, z1%mpc, mp_subzj%mpc, mpnw) 
 
4962
    return
 
4963
  end function
 
4964
 
 
4965
  function mp_subzq (za, qb)
 
4966
    implicit real*8 (d), type (mp_integer) (j), &
 
4967
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4968
    type (mp_complex):: mp_subzq
 
4969
    type (mp_complex) z1
 
4970
    intent (in):: za, qb
 
4971
    integer mpnw
 
4972
    mpnw = mpnwx
 
4973
    call mpmzc (qb%mpr, z1%mpc)
 
4974
    call mpcsub (mp4, za%mpc, z1%mpc, mp_subzq%mpc, mpnw) 
 
4975
    return
 
4976
  end function
 
4977
 
 
4978
  function mp_subzz (za, zb)
 
4979
    implicit real*8 (d), type (mp_integer) (j), &
 
4980
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4981
    type (mp_complex):: mp_subzz
 
4982
    intent (in):: za, zb
 
4983
    integer mpnw
 
4984
    mpnw = mpnwx
 
4985
    call mpcsub (mp4, za%mpc, zb%mpc, mp_subzz%mpc, mpnw) 
 
4986
    return
 
4987
  end function
 
4988
 
 
4989
  function mp_subiz (ia, zb)
 
4990
    implicit real*8 (d), type (mp_integer) (j), &
 
4991
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
4992
    type (mp_complex):: mp_subiz
 
4993
    intent (in):: ia, zb
 
4994
    type (mp_complex) z1
 
4995
    integer mpnw
 
4996
    mpnw = mpnwx
 
4997
    xa = ia
 
4998
    call mpxzc (xa, z1%mpc)
 
4999
    call mpcsub (mp4, z1%mpc, zb%mpc, mp_subiz%mpc, mpnw) 
 
5000
    return
 
5001
  end function
 
5002
 
 
5003
  function mp_subzi (za, ib)
 
5004
    implicit real*8 (d), type (mp_integer) (j), &
 
5005
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5006
    type (mp_complex):: mp_subzi
 
5007
    intent (in):: za, ib
 
5008
    type (mp_complex) z1
 
5009
    integer mpnw
 
5010
    mpnw = mpnwx
 
5011
    xb = ib
 
5012
    call mpxzc (xb, z1%mpc)
 
5013
    call mpcsub (mp4, za%mpc, z1%mpc, mp_subzi%mpc, mpnw) 
 
5014
    return
 
5015
  end function
 
5016
 
 
5017
  function mp_subdz (da, zb)
 
5018
    implicit real*8 (d), type (mp_integer) (j), &
 
5019
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5020
    type (mp_complex):: mp_subdz
 
5021
    intent (in):: da, zb
 
5022
    type (mp_complex) z1
 
5023
    integer mpnw
 
5024
    mpnw = mpnwx
 
5025
    xa = da
 
5026
    call mpxzc (xa, z1%mpc)
 
5027
    call mpcsub (mp4, z1%mpc, zb%mpc, mp_subdz%mpc, mpnw) 
 
5028
    return
 
5029
  end function
 
5030
 
 
5031
  function mp_subzd (za, db)
 
5032
    implicit real*8 (d), type (mp_integer) (j), &
 
5033
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5034
    type (mp_complex):: mp_subzd
 
5035
    intent (in):: za, db
 
5036
    type (mp_complex) z1
 
5037
    integer mpnw
 
5038
    mpnw = mpnwx
 
5039
    xb = db
 
5040
    call mpxzc (xb, z1%mpc)
 
5041
    call mpcsub (mp4, za%mpc, z1%mpc, mp_subzd%mpc, mpnw) 
 
5042
    return
 
5043
  end function
 
5044
 
 
5045
  function mp_subxz (xa, zb)
 
5046
    implicit real*8 (d), type (mp_integer) (j), &
 
5047
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5048
    type (mp_complex):: mp_subxz
 
5049
    intent (in):: xa, zb
 
5050
    type (mp_complex) z1
 
5051
    integer mpnw
 
5052
    mpnw = mpnwx
 
5053
    call mpxzc (xa, z1%mpc)
 
5054
    call mpcsub (mp4, z1%mpc, zb%mpc, mp_subxz%mpc, mpnw) 
 
5055
    return
 
5056
  end function
 
5057
 
 
5058
  function mp_subzx (za, xb)
 
5059
    implicit real*8 (d), type (mp_integer) (j), &
 
5060
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5061
    type (mp_complex):: mp_subzx
 
5062
    intent (in):: za, xb
 
5063
    type (mp_complex) z1
 
5064
    integer mpnw
 
5065
    mpnw = mpnwx
 
5066
    call mpxzc (xb, z1%mpc)
 
5067
    call mpcsub (mp4, za%mpc, z1%mpc, mp_subzx%mpc, mpnw) 
 
5068
    return
 
5069
  end function
 
5070
 
 
5071
!  MPC negation routine.
 
5072
 
 
5073
  function mp_negz (za)
 
5074
    implicit real*8 (d), type (mp_integer) (j), &
 
5075
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5076
    type (mp_complex):: mp_negz
 
5077
    intent (in):: za
 
5078
    integer mpnw
 
5079
    mpnw = mpnwx
 
5080
    call mpceq (mp4, za%mpc, mp_negz%mpc, mpnw) 
 
5081
    mp_negz%mpc(1) = - za%mpc(1)
 
5082
    mp_negz%mpc(mp41) = - za%mpc(mp41)
 
5083
    return
 
5084
  end function
 
5085
 
 
5086
!  MPC multiply routines.
 
5087
 
 
5088
  function mp_mulzj (za, jb)
 
5089
    implicit real*8 (d), type (mp_integer) (j), &
 
5090
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5091
    type (mp_complex):: mp_mulzj
 
5092
    intent (in):: za, jb
 
5093
    type (mp_complex) z1
 
5094
    integer mpnw
 
5095
    mpnw = mpnwx
 
5096
    call mpmzc (jb%mpi, z1%mpc)
 
5097
    call mpcmul (mp4, za%mpc, z1%mpc, mp_mulzj%mpc, mpnw) 
 
5098
    return
 
5099
  end function
 
5100
 
 
5101
  function mp_mulzq (za, qb)
 
5102
    implicit real*8 (d), type (mp_integer) (j), &
 
5103
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5104
    type (mp_complex):: mp_mulzq
 
5105
    intent (in):: za, qb
 
5106
    type (mp_complex) z1
 
5107
    integer mpnw
 
5108
    mpnw = mpnwx
 
5109
    call mpmzc (qb%mpr, z1%mpc)
 
5110
    call mpcmul (mp4, za%mpc, z1%mpc, mp_mulzq%mpc, mpnw) 
 
5111
    return
 
5112
  end function
 
5113
 
 
5114
  function mp_mulzz (za, zb)
 
5115
    implicit real*8 (d), type (mp_integer) (j), &
 
5116
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5117
    type (mp_complex):: mp_mulzz
 
5118
    intent (in):: za, zb
 
5119
    integer mpnw
 
5120
    mpnw = mpnwx
 
5121
    call mpcmul (mp4, za%mpc, zb%mpc, mp_mulzz%mpc, mpnw) 
 
5122
    return
 
5123
  end function
 
5124
 
 
5125
  function mp_muliz (ia, zb)
 
5126
    implicit real*8 (d), type (mp_integer) (j), &
 
5127
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5128
    type (mp_complex):: mp_muliz
 
5129
    intent (in):: ia, zb
 
5130
    type (mp_complex) z1
 
5131
    integer mpnw
 
5132
    mpnw = mpnwx
 
5133
    xa = ia
 
5134
    call mpxzc (xa, z1%mpc)
 
5135
    call mpcmul (mp4, z1%mpc, zb%mpc, mp_muliz%mpc, mpnw) 
 
5136
    return
 
5137
  end function
 
5138
 
 
5139
  function mp_mulzi (za, ib)
 
5140
    implicit real*8 (d), type (mp_integer) (j), &
 
5141
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5142
    type (mp_complex):: mp_mulzi
 
5143
    intent (in):: za, ib
 
5144
    type (mp_complex) z1
 
5145
    integer mpnw
 
5146
    mpnw = mpnwx
 
5147
    xb = ib
 
5148
    call mpxzc (xb, z1%mpc)
 
5149
    call mpcmul (mp4, za%mpc, z1%mpc, mp_mulzi%mpc, mpnw) 
 
5150
    return
 
5151
  end function
 
5152
 
 
5153
  function mp_muldz (da, zb)
 
5154
    implicit real*8 (d), type (mp_integer) (j), &
 
5155
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5156
    type (mp_complex):: mp_muldz
 
5157
    intent (in):: da, zb
 
5158
    type (mp_complex) z1
 
5159
    integer mpnw
 
5160
    mpnw = mpnwx
 
5161
    xa = da
 
5162
    call mpxzc (xa, z1%mpc)
 
5163
    call mpcmul (mp4, z1%mpc, zb%mpc, mp_muldz%mpc, mpnw) 
 
5164
    return
 
5165
  end function
 
5166
 
 
5167
  function mp_mulzd (za, db)
 
5168
    implicit real*8 (d), type (mp_integer) (j), &
 
5169
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5170
    type (mp_complex):: mp_mulzd
 
5171
    intent (in):: za, db
 
5172
    type (mp_complex) z1
 
5173
    integer mpnw
 
5174
    mpnw = mpnwx
 
5175
    xb = db
 
5176
    call mpxzc (xb, z1%mpc)
 
5177
    call mpcmul (mp4, za%mpc, z1%mpc, mp_mulzd%mpc, mpnw) 
 
5178
    return
 
5179
  end function
 
5180
 
 
5181
  function mp_mulxz (xa, zb)
 
5182
    implicit real*8 (d), type (mp_integer) (j), &
 
5183
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5184
    type (mp_complex):: mp_mulxz
 
5185
    intent (in):: xa, zb
 
5186
    type (mp_complex) z1
 
5187
    integer mpnw
 
5188
    mpnw = mpnwx
 
5189
    call mpxzc (xa, z1%mpc)
 
5190
    call mpcmul (mp4, z1%mpc, zb%mpc, mp_mulxz%mpc, mpnw) 
 
5191
    return
 
5192
  end function
 
5193
 
 
5194
  function mp_mulzx (za, xb)
 
5195
    implicit real*8 (d), type (mp_integer) (j), &
 
5196
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5197
    type (mp_complex):: mp_mulzx
 
5198
    intent (in):: za, xb
 
5199
    type (mp_complex) z1
 
5200
    integer mpnw
 
5201
    mpnw = mpnwx
 
5202
    call mpxzc (xb, z1%mpc)
 
5203
    call mpcmul (mp4, za%mpc, z1%mpc, mp_mulzx%mpc, mpnw) 
 
5204
    return
 
5205
  end function
 
5206
 
 
5207
!  MPC divide routines.
 
5208
 
 
5209
  function mp_divzj (za, jb)
 
5210
    implicit real*8 (d), type (mp_integer) (j), &
 
5211
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5212
    type (mp_complex):: mp_divzj
 
5213
    intent (in):: za, jb
 
5214
    type (mp_complex) z1
 
5215
    integer mpnw
 
5216
    mpnw = mpnwx
 
5217
    call mpmzc (jb%mpi, z1%mpc)
 
5218
    call mpcdiv (mp4, za%mpc, z1%mpc, mp_divzj%mpc, mpnw) 
 
5219
    return
 
5220
  end function
 
5221
 
 
5222
  function mp_divzq (za, qb)
 
5223
    implicit real*8 (d), type (mp_integer) (j), &
 
5224
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5225
    type (mp_complex):: mp_divzq
 
5226
    intent (in):: za, qb
 
5227
    type (mp_complex) z1
 
5228
    integer mpnw
 
5229
    mpnw = mpnwx
 
5230
    call mpmzc (qb%mpr, z1%mpc)
 
5231
    call mpcdiv (mp4, za%mpc, z1%mpc, mp_divzq%mpc, mpnw) 
 
5232
    return
 
5233
  end function
 
5234
 
 
5235
  function mp_divzz (za, zb)
 
5236
    implicit real*8 (d), type (mp_integer) (j), &
 
5237
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5238
    type (mp_complex):: mp_divzz
 
5239
    intent (in):: za, zb
 
5240
    integer mpnw
 
5241
    mpnw = mpnwx
 
5242
    call mpcdiv (mp4, za%mpc, zb%mpc, mp_divzz%mpc, mpnw) 
 
5243
    return
 
5244
  end function
 
5245
 
 
5246
  function mp_diviz (ia, zb)
 
5247
    implicit real*8 (d), type (mp_integer) (j), &
 
5248
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5249
    type (mp_complex):: mp_diviz
 
5250
    intent (in):: ia, zb
 
5251
    type (mp_complex) z1
 
5252
    integer mpnw
 
5253
    mpnw = mpnwx
 
5254
    xa = ia
 
5255
    call mpxzc (xa, z1%mpc)
 
5256
    call mpcdiv (mp4, z1%mpc, zb%mpc, mp_diviz%mpc, mpnw) 
 
5257
    return
 
5258
  end function
 
5259
 
 
5260
  function mp_divzi (za, ib)
 
5261
    implicit real*8 (d), type (mp_integer) (j), &
 
5262
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5263
    type (mp_complex):: mp_divzi
 
5264
    intent (in):: za, ib
 
5265
    type (mp_complex) z1
 
5266
    integer mpnw
 
5267
    mpnw = mpnwx
 
5268
    xb = ib
 
5269
    call mpxzc (xb, z1%mpc)
 
5270
    call mpcdiv (mp4, za%mpc, z1%mpc, mp_divzi%mpc, mpnw) 
 
5271
    return
 
5272
  end function
 
5273
 
 
5274
  function mp_divdz (da, zb)
 
5275
    implicit real*8 (d), type (mp_integer) (j), &
 
5276
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5277
    type (mp_complex):: mp_divdz
 
5278
    intent (in):: da, zb
 
5279
    type (mp_complex) z1
 
5280
    integer mpnw
 
5281
    mpnw = mpnwx
 
5282
    xa = da
 
5283
    call mpxzc (xa, z1%mpc)
 
5284
    call mpcdiv (mp4, z1%mpc, zb%mpc, mp_divdz%mpc, mpnw) 
 
5285
    return
 
5286
  end function
 
5287
 
 
5288
  function mp_divzd (za, db)
 
5289
    implicit real*8 (d), type (mp_integer) (j), &
 
5290
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5291
    type (mp_complex):: mp_divzd
 
5292
    intent (in):: za, db
 
5293
    type (mp_complex) z1
 
5294
    integer mpnw
 
5295
    mpnw = mpnwx
 
5296
    xb = db
 
5297
    call mpxzc (xb, z1%mpc)
 
5298
    call mpcdiv (mp4, za%mpc, z1%mpc, mp_divzd%mpc, mpnw) 
 
5299
    return
 
5300
  end function
 
5301
 
 
5302
  function mp_divxz (xa, zb)
 
5303
    implicit real*8 (d), type (mp_integer) (j), &
 
5304
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5305
    type (mp_complex):: mp_divxz
 
5306
    intent (in):: xa, zb
 
5307
    type (mp_complex) z1
 
5308
    integer mpnw
 
5309
    mpnw = mpnwx
 
5310
    call mpxzc (xa, z1%mpc)
 
5311
    call mpcdiv (mp4, z1%mpc, zb%mpc, mp_divxz%mpc, mpnw) 
 
5312
    return
 
5313
  end function
 
5314
 
 
5315
  function mp_divzx (za, xb)
 
5316
    implicit real*8 (d), type (mp_integer) (j), &
 
5317
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5318
    type (mp_complex):: mp_divzx
 
5319
    intent (in):: za, xb
 
5320
    type (mp_complex) z1
 
5321
    integer mpnw
 
5322
    mpnw = mpnwx
 
5323
    call mpxzc (xb, z1%mpc)
 
5324
    call mpcdiv (mp4, za%mpc, z1%mpc, mp_divzx%mpc, mpnw) 
 
5325
    return
 
5326
  end function
 
5327
 
 
5328
!  MPC exponentiation routines.
 
5329
 
 
5330
  function mp_expzi (za, ib)
 
5331
    implicit real*8 (d), type (mp_integer) (j), &
 
5332
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5333
    type (mp_complex):: mp_expzi
 
5334
    intent (in):: za, ib
 
5335
    integer mpnw
 
5336
    mpnw = mpnwx
 
5337
    call mpcpwr (mp4, za%mpc, ib, mp_expzi%mpc, mpnw) 
 
5338
    return
 
5339
  end function
 
5340
 
 
5341
!  MPC .EQ. routines.
 
5342
 
 
5343
  function mp_eqtzj (za, jb)
 
5344
    implicit real*8 (d), type (mp_integer) (j), &
 
5345
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5346
    logical mp_eqtzj
 
5347
    intent (in):: za, jb
 
5348
    type (mp_complex) z1
 
5349
    integer mpnw
 
5350
    mpnw = mpnwx
 
5351
    call mpmzc (jb%mpi, z1%mpc)
 
5352
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5353
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5354
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5355
      mp_eqtzj = .true.
 
5356
    else
 
5357
      mp_eqtzj = .false.
 
5358
    endif
 
5359
    return
 
5360
  end function
 
5361
 
 
5362
  function mp_eqtzq (za, qb)
 
5363
    implicit real*8 (d), type (mp_integer) (j), &
 
5364
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5365
    logical mp_eqtzq
 
5366
    intent (in):: za, qb
 
5367
    type (mp_complex) z1
 
5368
    integer mpnw
 
5369
    mpnw = mpnwx
 
5370
    call mpmzc (qb%mpr, z1%mpc)
 
5371
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5372
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5373
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5374
      mp_eqtzq = .true.
 
5375
    else
 
5376
      mp_eqtzq = .false.
 
5377
    endif
 
5378
    return
 
5379
  end function
 
5380
 
 
5381
  function mp_eqtzz (za, zb)
 
5382
    implicit real*8 (d), type (mp_integer) (j), &
 
5383
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5384
    logical mp_eqtzz
 
5385
    intent (in):: za, zb
 
5386
    integer mpnw
 
5387
    mpnw = mpnwx
 
5388
    call mpcpr (za%mpc, zb%mpc, ic1, mpnw) 
 
5389
    call mpcpr (za%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
5390
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5391
      mp_eqtzz = .true.
 
5392
    else
 
5393
      mp_eqtzz = .false.
 
5394
    endif
 
5395
    return
 
5396
  end function
 
5397
 
 
5398
  function mp_eqtiz (ia, zb)
 
5399
    implicit real*8 (d), type (mp_integer) (j), &
 
5400
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5401
    logical mp_eqtiz
 
5402
    intent (in):: ia, zb
 
5403
    type (mp_complex) z1
 
5404
    integer mpnw
 
5405
    mpnw = mpnwx
 
5406
    da = ia
 
5407
    call mpdmc (da, 0, z1%mpc)
 
5408
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
5409
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
5410
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5411
      mp_eqtiz = .true.
 
5412
    else
 
5413
      mp_eqtiz = .false.
 
5414
    endif
 
5415
    return
 
5416
  end function
 
5417
 
 
5418
  function mp_eqtzi (za, ib)
 
5419
    implicit real*8 (d), type (mp_integer) (j), &
 
5420
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5421
    logical mp_eqtzi
 
5422
    intent (in):: za, ib
 
5423
    type (mp_complex) z1
 
5424
    integer mpnw
 
5425
    mpnw = mpnwx
 
5426
    db = ib
 
5427
    call mpdmc (db, 0, z1%mpc)
 
5428
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5429
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5430
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5431
      mp_eqtzi = .true.
 
5432
    else
 
5433
      mp_eqtzi = .false.
 
5434
    endif
 
5435
    return
 
5436
  end function
 
5437
 
 
5438
  function mp_eqtdz (da, zb)
 
5439
    implicit real*8 (d), type (mp_integer) (j), &
 
5440
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5441
    logical mp_eqtdz
 
5442
    intent (in):: da, zb
 
5443
    type (mp_complex) z1
 
5444
    integer mpnw
 
5445
    mpnw = mpnwx
 
5446
    call mpdmc (da, 0, z1%mpc)
 
5447
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
5448
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
5449
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5450
      mp_eqtdz = .true.
 
5451
    else
 
5452
      mp_eqtdz = .false.
 
5453
    endif
 
5454
    return
 
5455
  end function
 
5456
 
 
5457
  function mp_eqtzd (za, db)
 
5458
    implicit real*8 (d), type (mp_integer) (j), &
 
5459
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5460
    logical mp_eqtzd
 
5461
    intent (in):: za, db
 
5462
    type (mp_complex) z1
 
5463
    integer mpnw
 
5464
    mpnw = mpnwx
 
5465
    call mpdmc (db, 0, z1%mpc)
 
5466
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5467
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5468
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5469
      mp_eqtzd = .true.
 
5470
    else
 
5471
      mp_eqtzd = .false.
 
5472
    endif
 
5473
    return
 
5474
  end function
 
5475
 
 
5476
  function mp_eqtxz (xa, zb)
 
5477
    implicit real*8 (d), type (mp_integer) (j), &
 
5478
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5479
    logical mp_eqtxz
 
5480
    intent (in):: xa, zb
 
5481
    type (mp_complex) z1
 
5482
    integer mpnw
 
5483
    mpnw = mpnwx
 
5484
    call mpxzc (xa, z1%mpc)
 
5485
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
5486
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
5487
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5488
      mp_eqtxz = .true.
 
5489
    else
 
5490
      mp_eqtxz = .false.
 
5491
    endif
 
5492
    return
 
5493
  end function
 
5494
 
 
5495
  function mp_eqtzx (za, xb)
 
5496
    implicit real*8 (d), type (mp_integer) (j), &
 
5497
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5498
    logical mp_eqtzx
 
5499
    intent (in):: za, xb
 
5500
    type (mp_complex) z1
 
5501
    integer mpnw
 
5502
    mpnw = mpnwx
 
5503
    call mpxzc (xb, z1%mpc)
 
5504
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5505
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5506
    if (ic1 .eq. 0 .and. ic2 .eq. 0) then
 
5507
      mp_eqtzx = .true.
 
5508
    else
 
5509
      mp_eqtzx = .false.
 
5510
    endif
 
5511
    return
 
5512
  end function
 
5513
 
 
5514
!  MPC .NE. routines.
 
5515
 
 
5516
  function mp_netzj (za, jb)
 
5517
    implicit real*8 (d), type (mp_integer) (j), &
 
5518
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5519
    logical mp_netzj
 
5520
    intent (in):: za, jb
 
5521
    type (mp_complex) z1
 
5522
    integer mpnw
 
5523
    mpnw = mpnwx
 
5524
    call mpmzc (jb%mpi, z1%mpc)
 
5525
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5526
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5527
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5528
      mp_netzj = .true.
 
5529
    else
 
5530
      mp_netzj = .false.
 
5531
    endif
 
5532
    return
 
5533
  end function
 
5534
 
 
5535
  function mp_netzq (za, qb)
 
5536
    implicit real*8 (d), type (mp_integer) (j), &
 
5537
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5538
    logical mp_netzq
 
5539
    intent (in):: za, qb
 
5540
    type (mp_complex) z1
 
5541
    integer mpnw
 
5542
    mpnw = mpnwx
 
5543
    call mpmzc (qb%mpr, z1%mpc)
 
5544
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5545
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5546
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5547
      mp_netzq = .true.
 
5548
    else
 
5549
      mp_netzq = .false.
 
5550
    endif
 
5551
    return
 
5552
  end function
 
5553
 
 
5554
  function mp_netzz (za, zb)
 
5555
    implicit real*8 (d), type (mp_integer) (j), &
 
5556
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5557
    logical mp_netzz
 
5558
    intent (in):: za, zb
 
5559
    integer mpnw
 
5560
    mpnw = mpnwx
 
5561
    call mpcpr (za%mpc, zb%mpc, ic1, mpnw) 
 
5562
    call mpcpr (za%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
5563
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5564
      mp_netzz = .true.
 
5565
    else
 
5566
      mp_netzz = .false.
 
5567
    endif
 
5568
    return
 
5569
  end function
 
5570
 
 
5571
  function mp_netiz (ia, zb)
 
5572
    implicit real*8 (d), type (mp_integer) (j), &
 
5573
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5574
    logical mp_netiz
 
5575
    intent (in):: ia, zb
 
5576
    type (mp_complex) z1
 
5577
    integer mpnw
 
5578
    mpnw = mpnwx
 
5579
    da = ia
 
5580
    call mpdmc (da, 0, z1%mpc)
 
5581
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
5582
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
5583
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5584
      mp_netiz = .true.
 
5585
    else
 
5586
      mp_netiz = .false.
 
5587
    endif
 
5588
    return
 
5589
  end function
 
5590
 
 
5591
  function mp_netzi (za, ib)
 
5592
    implicit real*8 (d), type (mp_integer) (j), &
 
5593
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5594
    logical mp_netzi
 
5595
    intent (in):: za, ib
 
5596
    type (mp_complex) z1
 
5597
    integer mpnw
 
5598
    mpnw = mpnwx
 
5599
    db = ib
 
5600
    call mpdmc (db, 0, z1%mpc)
 
5601
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5602
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5603
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5604
      mp_netzi = .true.
 
5605
    else
 
5606
      mp_netzi = .false.
 
5607
    endif
 
5608
    return
 
5609
  end function
 
5610
 
 
5611
  function mp_netdz (da, zb)
 
5612
    implicit real*8 (d), type (mp_integer) (j), &
 
5613
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5614
    logical mp_netdz
 
5615
    intent (in):: da, zb
 
5616
    type (mp_complex) z1
 
5617
    integer mpnw
 
5618
    mpnw = mpnwx
 
5619
    call mpdmc (da, 0, z1%mpc)
 
5620
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
5621
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
5622
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5623
      mp_netdz = .true.
 
5624
    else
 
5625
      mp_netdz = .false.
 
5626
    endif
 
5627
    return
 
5628
  end function
 
5629
 
 
5630
  function mp_netzd (za, db)
 
5631
    implicit real*8 (d), type (mp_integer) (j), &
 
5632
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5633
    logical mp_netzd
 
5634
    intent (in):: za, db
 
5635
    type (mp_complex) z1
 
5636
    integer mpnw
 
5637
    mpnw = mpnwx
 
5638
    call mpdmc (db, 0, z1%mpc)
 
5639
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5640
    call mpcpr (za%mpc(mp41), z1%mpc(mp41), ic2, mpnw) 
 
5641
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5642
      mp_netzd = .true.
 
5643
    else
 
5644
      mp_netzd = .false.
 
5645
    endif
 
5646
    return
 
5647
  end function
 
5648
 
 
5649
  function mp_netxz (xa, zb)
 
5650
    implicit real*8 (d), type (mp_integer) (j), &
 
5651
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5652
    logical mp_netxz
 
5653
    intent (in):: xa, zb
 
5654
    type (mp_complex) z1
 
5655
    integer mpnw
 
5656
    mpnw = mpnwx
 
5657
    call mpxzc (xa, z1%mpc)
 
5658
    call mpcpr (z1%mpc, zb%mpc, ic1, mpnw) 
 
5659
    call mpcpr (z1%mpc(mp41), zb%mpc(mp41), ic2, mpnw) 
 
5660
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5661
      mp_netxz = .true.
 
5662
    else
 
5663
      mp_netxz = .false.
 
5664
    endif
 
5665
    return
 
5666
  end function
 
5667
 
 
5668
  function mp_netzx (za, xb)
 
5669
    implicit real*8 (d), type (mp_integer) (j), &
 
5670
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5671
    logical mp_netzx
 
5672
    intent (in):: za, xb
 
5673
    type (mp_complex) z1
 
5674
    integer mpnw
 
5675
    mpnw = mpnwx
 
5676
    call mpxzc (xb, z1%mpc)
 
5677
    call mpcpr (za%mpc, z1%mpc, ic1, mpnw) 
 
5678
    call mpcpr (za%mpc(mp41), z2%mpc(mp41), ic2, mpnw) 
 
5679
    if (ic1 .ne. 0 .or. ic2 .ne. 0) then
 
5680
      mp_netzx = .true.
 
5681
    else
 
5682
      mp_netzx = .false.
 
5683
    endif
 
5684
    return
 
5685
  end function
 
5686
 
 
5687
end module
 
5688
 
 
5689
 
 
5690
module mpgenmod
 
5691
 
 
5692
!  This Fortran-90 module defines generic functions involving all
 
5693
!  MP datatypes.
 
5694
 
 
5695
!  The subroutines and functions defined in this module are private
 
5696
!  and not intended to be called directly by the user.  The generic
 
5697
!  names (i.e. interface block names) are publicly accessible, though.
 
5698
 
 
5699
use mpfunmod
 
5700
use mpdefmod
 
5701
private kdb, mp4, mp24, mp41
 
5702
parameter (kdb = kind (0.d0), mp4 = mpwds + 4, mp24 = 2 * mp4, mp41 = mp4 + 1)
 
5703
private &
 
5704
  mp_absj, mp_absq, mp_absz, mp_acos, mp_imag, mp_aint, mp_anint, &
 
5705
  mp_asin, mp_atan, mp_atan2, mp_jtoc, mp_qtoc, mp_ztoc, mp_conjg, &
 
5706
  mp_cos, mp_cosz, mp_cosh, mp_jtod, mp_qtod, mp_ztod, mp_jtox, mp_qtox, &
 
5707
  mp_ztox, mp_exp, mp_expz, mp_jtoi, mp_qtoi, mp_ztoi, mp_log, mp_logz, &
 
5708
  mp_log10, mp_maxj, mp_maxq, mp_maxq3, mp_minj, mp_minq, mp_minq3, mp_modj, &
 
5709
  mp_modq, mp_jtoz, mp_qtoz, mp_itoz, mp_dtoz, mp_xtoz, &
 
5710
  mp_atoz, mp_jjtoz, mp_qqtoz, mp_iitoz, mp_ddtoz, mp_aatoz, &
 
5711
  mp_cssh, mp_cssn, mp_qtoj, mp_ztoj, mp_itoj, mp_rtoj, mp_ctoj, mp_dtoj, &
 
5712
  mp_xtoj, mp_atoj, mp_nrt, mp_rand, mp_inpj, mp_inpq, mp_inpz, &
 
5713
  mp_jtoq, mp_ztoq, mp_itoq, mp_dtoq, mp_xtoq, &
 
5714
  mp_atoq, mp_outj, mp_outq, mp_outz, mp_nint, &
 
5715
  mp_signj, mp_signq, mp_sin, mp_sinz, mp_sinh, mp_sqrtq, &
 
5716
  mp_sqrtz, mp_tan, mp_tanh
 
5717
 
 
5718
!  MP generic interface blocks.
 
5719
 
 
5720
interface abs
 
5721
  module procedure mp_absj
 
5722
  module procedure mp_absq
 
5723
  module procedure mp_absz
 
5724
end interface
 
5725
 
 
5726
interface acos
 
5727
  module procedure mp_acos
 
5728
end interface
 
5729
 
 
5730
interface aimag
 
5731
  module procedure mp_imag
 
5732
end interface
 
5733
 
 
5734
interface aint
 
5735
  module procedure mp_aint
 
5736
end interface
 
5737
 
 
5738
interface anint
 
5739
  module procedure mp_anint
 
5740
end interface
 
5741
 
 
5742
interface asin
 
5743
  module procedure mp_asin
 
5744
end interface
 
5745
 
 
5746
interface atan
 
5747
  module procedure mp_atan
 
5748
end interface
 
5749
 
 
5750
interface atan2
 
5751
  module procedure mp_atan2
 
5752
end interface
 
5753
 
 
5754
interface cmplx
 
5755
  module procedure mp_jtoc
 
5756
  module procedure mp_qtoc
 
5757
  module procedure mp_ztoc
 
5758
end interface
 
5759
 
 
5760
interface conjg
 
5761
  module procedure mp_conjg
 
5762
end interface
 
5763
 
 
5764
interface cos
 
5765
  module procedure mp_cos
 
5766
  module procedure mp_cosz
 
5767
end interface
 
5768
 
 
5769
interface cosh
 
5770
  module procedure mp_cosh
 
5771
end interface
 
5772
 
 
5773
interface dble
 
5774
  module procedure mp_jtod
 
5775
  module procedure mp_qtod
 
5776
  module procedure mp_ztod
 
5777
end interface
 
5778
 
 
5779
interface dcmplx
 
5780
  module procedure mp_jtox
 
5781
  module procedure mp_qtox
 
5782
  module procedure mp_ztox
 
5783
end interface
 
5784
 
 
5785
interface exp
 
5786
  module procedure mp_exp
 
5787
  module procedure mp_expz
 
5788
end interface
 
5789
 
 
5790
interface int
 
5791
  module procedure mp_jtoi
 
5792
  module procedure mp_qtoi
 
5793
  module procedure mp_ztoi
 
5794
end interface
 
5795
 
 
5796
interface log
 
5797
  module procedure mp_log
 
5798
  module procedure mp_logz
 
5799
end interface
 
5800
 
 
5801
interface log10
 
5802
  module procedure mp_log10
 
5803
end interface
 
5804
 
 
5805
interface max
 
5806
  module procedure mp_maxj
 
5807
  module procedure mp_maxq
 
5808
  module procedure mp_maxq3
 
5809
end interface
 
5810
 
 
5811
interface min
 
5812
  module procedure mp_minj
 
5813
  module procedure mp_minq
 
5814
  module procedure mp_minq3
 
5815
end interface
 
5816
 
 
5817
interface mod
 
5818
  module procedure mp_modj
 
5819
  module procedure mp_modq
 
5820
end interface
 
5821
 
 
5822
interface mpcmpl
 
5823
  module procedure mp_jtoz
 
5824
  module procedure mp_qtoz
 
5825
  module procedure mp_itoz
 
5826
  module procedure mp_dtoz
 
5827
  module procedure mp_xtoz
 
5828
 
 
5829
  module procedure mp_atoz
 
5830
 
 
5831
  module procedure mp_jjtoz
 
5832
  module procedure mp_qqtoz
 
5833
  module procedure mp_iitoz
 
5834
  module procedure mp_ddtoz
 
5835
 
 
5836
  module procedure mp_aatoz
 
5837
end interface
 
5838
 
 
5839
interface mpcsshf
 
5840
  module procedure mp_cssh
 
5841
end interface
 
5842
 
 
5843
interface mpcssnf
 
5844
  module procedure mp_cssn
 
5845
end interface
 
5846
 
 
5847
interface mpint
 
5848
  module procedure mp_qtoj
 
5849
  module procedure mp_ztoj
 
5850
  module procedure mp_itoj
 
5851
  module procedure mp_dtoj
 
5852
  module procedure mp_xtoj
 
5853
 
 
5854
  module procedure mp_atoj
 
5855
end interface
 
5856
 
 
5857
interface mpnrtf
 
5858
  module procedure mp_nrt
 
5859
end interface
 
5860
 
 
5861
interface mpranf
 
5862
  module procedure mp_rand
 
5863
end interface
 
5864
 
 
5865
interface mpread
 
5866
  module procedure mp_inpj
 
5867
  module procedure mp_inpq
 
5868
  module procedure mp_inpz
 
5869
end interface
 
5870
 
 
5871
interface mpreal
 
5872
  module procedure mp_jtoq
 
5873
  module procedure mp_ztoq
 
5874
  module procedure mp_itoq
 
5875
  module procedure mp_dtoq
 
5876
  module procedure mp_xtoq
 
5877
 
 
5878
  module procedure mp_atoq
 
5879
end interface
 
5880
 
 
5881
interface mpwrite
 
5882
  module procedure mp_outj
 
5883
  module procedure mp_outq
 
5884
  module procedure mp_outz
 
5885
end interface
 
5886
 
 
5887
interface nint
 
5888
  module procedure mp_nint
 
5889
end interface
 
5890
 
 
5891
interface sign
 
5892
  module procedure mp_signj
 
5893
  module procedure mp_signq
 
5894
end interface
 
5895
 
 
5896
interface sin
 
5897
  module procedure mp_sin
 
5898
  module procedure mp_sinz
 
5899
end interface
 
5900
 
 
5901
interface sinh
 
5902
  module procedure mp_sinh
 
5903
end interface
 
5904
 
 
5905
interface sqrt
 
5906
  module procedure mp_sqrtq
 
5907
  module procedure mp_sqrtz
 
5908
end interface
 
5909
 
 
5910
interface tan
 
5911
  module procedure mp_tan
 
5912
end interface
 
5913
 
 
5914
interface tanh
 
5915
  module procedure mp_tanh
 
5916
end interface
 
5917
 
 
5918
contains
 
5919
 
 
5920
  function mp_absj (ja)
 
5921
    implicit real*8 (d), type (mp_integer) (j), &
 
5922
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5923
    type (mp_integer):: mp_absj
 
5924
    intent (in):: ja
 
5925
    integer mpnw
 
5926
    mpnw = mpnwx
 
5927
    call mpeq (ja%mpi, mp_absj%mpi, mpnw) 
 
5928
    mp_absj%mpi(1) = abs (ja%mpi(1))
 
5929
    return
 
5930
  end function
 
5931
 
 
5932
  function mp_absq (qa)
 
5933
    implicit real*8 (d), type (mp_integer) (j), &
 
5934
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5935
    type (mp_real):: mp_absq
 
5936
    intent (in):: qa
 
5937
    integer mpnw
 
5938
    mpnw = mpnwx
 
5939
    call mpeq (qa%mpr, mp_absq%mpr, mpnw) 
 
5940
    mp_absq%mpr(1) = abs (qa%mpr(1))
 
5941
    return
 
5942
  end function
 
5943
 
 
5944
  function mp_absz (za)
 
5945
    implicit real*8 (d), type (mp_integer) (j), &
 
5946
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5947
    type (mp_real):: mp_absz
 
5948
    intent (in):: za
 
5949
    type (mp_real) q1, q2, q3
 
5950
    integer mpnw
 
5951
    mpnw = mpnwx
 
5952
    call mpmul (za%mpc, za%mpc, q1%mpr, mpnw) 
 
5953
    call mpmul (za%mpc(mp41), za%mpc(mp41), q2%mpr, mpnw) 
 
5954
    call mpadd (q1%mpr, q2%mpr, q3%mpr, mpnw) 
 
5955
    call mpsqrt (q3%mpr, mp_absz%mpr, mpnw) 
 
5956
    return
 
5957
  end function
 
5958
 
 
5959
  function mp_acos (qa)
 
5960
    implicit real*8 (d), type (mp_integer) (j), &
 
5961
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5962
    type (mp_real):: mp_acos
 
5963
    intent (in):: qa
 
5964
    type (mp_real) q1, q2, q3
 
5965
    integer mpnw
 
5966
    mpnw = mpnwx
 
5967
    call mpdmc (1.d0, 0, q1%mpr)
 
5968
    call mpmul (qa%mpr, qa%mpr, q2%mpr, mpnw) 
 
5969
    call mpsub (q1%mpr, q2%mpr, q3%mpr, mpnw) 
 
5970
    call mpsqrt (q3%mpr, q1%mpr, mpnw) 
 
5971
    call mpang (qa%mpr, q1%mpr, mppic%mpr, mp_acos%mpr, mpnw) 
 
5972
    return
 
5973
  end function
 
5974
 
 
5975
  function mp_aint (qa)
 
5976
    implicit real*8 (d), type (mp_integer) (j), &
 
5977
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5978
    type (mp_real):: mp_aint
 
5979
    intent (in):: qa
 
5980
    type (mp_real) q1
 
5981
    integer mpnw
 
5982
    mpnw = mpnwx
 
5983
    call mpinfr (qa%mpr, mp_aint%mpr, q1%mpr, mpnw) 
 
5984
    return
 
5985
  end function
 
5986
 
 
5987
  function mp_anint (qa)
 
5988
    implicit real*8 (d), type (mp_integer) (j), &
 
5989
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
5990
    type (mp_real):: mp_anint
 
5991
    intent (in):: qa
 
5992
    integer mpnw
 
5993
    mpnw = mpnwx
 
5994
    call mpnint (qa%mpr, mp_anint%mpr, mpnw) 
 
5995
    return
 
5996
  end function
 
5997
 
 
5998
  function mp_asin (qa)
 
5999
    implicit real*8 (d), type (mp_integer) (j), &
 
6000
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6001
    type (mp_real):: mp_asin
 
6002
    intent (in):: qa
 
6003
    type (mp_real) q1, q2, q3
 
6004
    integer mpnw
 
6005
    mpnw = mpnwx
 
6006
    call mpdmc (1.d0, 0, q1%mpr)
 
6007
    call mpmul (qa%mpr, qa%mpr, q2%mpr, mpnw) 
 
6008
    call mpsub (q1%mpr, q2%mpr, q3%mpr, mpnw) 
 
6009
    call mpsqrt (q3%mpr, q1%mpr, mpnw) 
 
6010
    call mpang (q1%mpr, qa%mpr, mppic%mpr, mp_asin%mpr, mpnw) 
 
6011
    return
 
6012
  end function
 
6013
 
 
6014
  function mp_atan (qa)
 
6015
    implicit real*8 (d), type (mp_integer) (j), &
 
6016
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6017
    type (mp_real):: mp_atan
 
6018
    intent (in):: qa
 
6019
    type (mp_real) q1
 
6020
    integer mpnw
 
6021
    mpnw = mpnwx
 
6022
    call mpdmc (1.d0, 0, q1%mpr)
 
6023
    call mpang (q1%mpr, qa%mpr, mppic%mpr, mp_atan%mpr, mpnw) 
 
6024
    return
 
6025
  end function
 
6026
 
 
6027
  function mp_atan2 (qa, qb)
 
6028
    implicit real*8 (d), type (mp_integer) (j), &
 
6029
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6030
    type (mp_real):: mp_atan2
 
6031
    intent (in):: qa, qb
 
6032
    integer mpnw
 
6033
    mpnw = mpnwx
 
6034
    call mpang (qb%mpr, qa%mpr, mppic%mpr, mp_atan2%mpr, mpnw) 
 
6035
    return
 
6036
  end function
 
6037
 
 
6038
  function mp_jtoc (ja, jb)
 
6039
    implicit real*8 (d), type (mp_integer) (j), &
 
6040
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6041
    complex:: mp_jtoc
 
6042
    intent (in):: ja, jb
 
6043
    integer mpnw
 
6044
    mpnw = mpnwx
 
6045
    call mpmdc (ja%mpi, da, ia)
 
6046
    call mpmdc (jb%mpi, db, ib)
 
6047
    mp_jtoc = cmplx (da * 2.d0 ** ia, db * 2.d0 ** ib)
 
6048
    return
 
6049
  end function
 
6050
 
 
6051
  function mp_qtoc (qa, qb)
 
6052
    implicit real*8 (d), type (mp_integer) (j), &
 
6053
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6054
    complex:: mp_qtoc
 
6055
    intent (in):: qa, qb
 
6056
    integer mpnw
 
6057
    mpnw = mpnwx
 
6058
    call mpmdc (qa%mpr, da, ia)
 
6059
    call mpmdc (qb%mpr, db, ib)
 
6060
    mp_qtoc = cmplx (da * 2.d0 ** ia, db * 2.d0 ** ib)
 
6061
    return
 
6062
  end function
 
6063
 
 
6064
  function mp_ztoc (za)
 
6065
    implicit real*8 (d), type (mp_integer) (j), &
 
6066
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6067
    complex:: mp_ztoc
 
6068
    intent (in):: za
 
6069
    integer mpnw
 
6070
    mpnw = mpnwx
 
6071
    call mpmdc (za%mpc, da, ia)
 
6072
    call mpmdc (za%mpc(mp41), db, ib)
 
6073
    mp_ztoc = cmplx (da * 2.d0 ** ia, db * 2.d0 ** ib)
 
6074
    return
 
6075
  end function
 
6076
 
 
6077
  function mp_conjg (za)
 
6078
    implicit real*8 (d), type (mp_integer) (j), &
 
6079
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6080
    type (mp_complex):: mp_conjg
 
6081
    intent (in):: za
 
6082
    integer mpnw
 
6083
    mpnw = mpnwx
 
6084
    call mpceq (mp4, za%mpc, mp_conjg%mpc, mpnw) 
 
6085
    mp_conjg%mpc(mp41) = - za%mpc(mp41)
 
6086
    return
 
6087
  end function
 
6088
 
 
6089
  function mp_cos (qa)
 
6090
    implicit real*8 (d), type (mp_integer) (j), &
 
6091
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6092
    type (mp_real):: mp_cos
 
6093
    intent (in):: qa
 
6094
    type (mp_real) q1
 
6095
    integer mpnw
 
6096
    mpnw = mpnwx
 
6097
    call mpcssn (qa%mpr, mppic%mpr, mp_cos%mpr, q1%mpr, mpnw) 
 
6098
    return
 
6099
  end function
 
6100
 
 
6101
  function mp_cosz (za)
 
6102
    implicit real*8 (d), type (mp_integer) (j), &
 
6103
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6104
    type (mp_complex):: mp_cosz
 
6105
    intent (in):: za
 
6106
    type (mp_real) q1, q2, q3, q4, q5, q6
 
6107
    integer mpnw
 
6108
    mpnw = mpnwx
 
6109
    call mpeq (za%mpc(mp41), q2%mpr, mpnw) 
 
6110
    q2%mpr(1) = - q2%mpr(1)
 
6111
    call mpexp (q2%mpr, mpl02%mpr, q1%mpr, mpnw) 
 
6112
    call mpdmc (1.d0, 0, q3%mpr)
 
6113
    call mpdiv (q3%mpr, q1%mpr, q2%mpr, mpnw) 
 
6114
    call mpcssn (za%mpc, mppic%mpr, q3%mpr, q4%mpr, mpnw) 
 
6115
    call mpadd (q1%mpr, q2%mpr, q5%mpr, mpnw) 
 
6116
    call mpmuld (q5%mpr, 0.5d0, 0, q6%mpr, mpnw) 
 
6117
    call mpmul (q6%mpr, q3%mpr, mp_cosz%mpc, mpnw) 
 
6118
    call mpsub (q1%mpr, q2%mpr, q5%mpr, mpnw) 
 
6119
    call mpmuld (q5%mpr, 0.5d0, 0, q6%mpr, mpnw) 
 
6120
    call mpmul (q6%mpr, q4%mpr, mp_cosz%mpc(mp41), mpnw) 
 
6121
    return
 
6122
  end function
 
6123
 
 
6124
  function mp_cosh (qa)
 
6125
    implicit real*8 (d), type (mp_integer) (j), &
 
6126
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6127
    type (mp_real):: mp_cosh
 
6128
    intent (in):: qa
 
6129
    type (mp_real) q1
 
6130
    integer mpnw
 
6131
    mpnw = mpnwx
 
6132
    call mpcssh (qa%mpr, mpl02%mpr, mp_cosh%mpr, q1%mpr, mpnw) 
 
6133
    return
 
6134
  end function
 
6135
 
 
6136
  function mp_jtod (ja)
 
6137
    implicit real*8 (d), type (mp_integer) (j), &
 
6138
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6139
    intent (in):: ja
 
6140
    double precision mp_jtod
 
6141
    integer mpnw
 
6142
    mpnw = mpnwx
 
6143
    call mpmdc (ja%mpi, da, ia)
 
6144
    mp_jtod = da * 2.d0 ** ia
 
6145
    return
 
6146
  end function
 
6147
 
 
6148
  function mp_qtod (qa)
 
6149
    implicit real*8 (d), type (mp_integer) (j), &
 
6150
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6151
    intent (in):: qa
 
6152
    double precision:: mp_qtod, da
 
6153
    integer mpnw
 
6154
    mpnw = mpnwx
 
6155
    call mpmdc (qa%mpr, da, ia)
 
6156
    mp_qtod = da * 2.d0 ** ia
 
6157
    return
 
6158
  end function
 
6159
 
 
6160
  function mp_ztod (za)
 
6161
    implicit real*8 (d), type (mp_integer) (j), &
 
6162
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6163
    intent (in):: za
 
6164
    double precision:: mp_ztod, da
 
6165
    integer mpnw
 
6166
    mpnw = mpnwx
 
6167
    call mpmdc (za%mpc, da, ia)
 
6168
    mp_ztod = da * 2.d0 ** ia
 
6169
    return
 
6170
  end function
 
6171
 
 
6172
  function mp_jtox (ja, jb)
 
6173
    implicit real*8 (d), type (mp_integer) (j), &
 
6174
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6175
    complex (kdb):: mp_jtox
 
6176
    intent (in):: ja, jb
 
6177
    integer mpnw
 
6178
    mpnw = mpnwx
 
6179
    call mpmdc (ja%mpi, da, ia)
 
6180
    call mpmdc (jb%mpi, db, ib)
 
6181
    mp_jtox = cmplx (da * 2.d0 ** ia, db * 2.d0 ** ib, kdb)
 
6182
    return
 
6183
  end function
 
6184
 
 
6185
  function mp_qtox (qa, qb)
 
6186
    implicit real*8 (d), type (mp_integer) (j), &
 
6187
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6188
    complex (kdb):: mp_qtox
 
6189
    intent (in):: qa, qb
 
6190
    integer mpnw
 
6191
    mpnw = mpnwx
 
6192
    call mpmdc (qa%mpr, da, ia)
 
6193
    call mpmdc (qb%mpr, db, ib)
 
6194
    mp_qtox = cmplx (da * 2.d0 ** ia, db * 2.d0 ** ib, kdb)
 
6195
    return
 
6196
  end function
 
6197
 
 
6198
  function mp_ztox (za)
 
6199
    implicit real*8 (d), type (mp_integer) (j), &
 
6200
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6201
    complex (kdb):: mp_ztox
 
6202
    intent (in):: za
 
6203
    integer mpnw
 
6204
    mpnw = mpnwx
 
6205
    call mpmdc (za%mpc, da, ia)
 
6206
    call mpmdc (za%mpc(mp41), db, ib)
 
6207
    mp_ztox = cmplx (da * 2.d0 ** ia, db * 2.d0 ** ib, kdb)
 
6208
    return
 
6209
  end function
 
6210
 
 
6211
  function mp_exp (qa)
 
6212
    implicit real*8 (d), type (mp_integer) (j), &
 
6213
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6214
    type (mp_real):: mp_exp
 
6215
    intent (in):: qa
 
6216
    integer mpnw
 
6217
    mpnw = mpnwx
 
6218
    call mpexp (qa%mpr, mpl02%mpr, mp_exp%mpr, mpnw) 
 
6219
    return
 
6220
  end function
 
6221
 
 
6222
  function mp_expz (za)
 
6223
    implicit real*8 (d), type (mp_integer) (j), &
 
6224
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6225
    type (mp_complex):: mp_expz
 
6226
    intent (in):: za
 
6227
    type (mp_real) q1, q2, q3
 
6228
    integer mpnw
 
6229
    mpnw = mpnwx
 
6230
    call mpexp (za%mpc, mpl02%mpr, q1%mpr, mpnw) 
 
6231
    call mpcssn (za%mpc(mp41), mppic%mpr, q2%mpr, q3%mpr, mpnw) 
 
6232
    call mpmul (q1%mpr, q2%mpr, mp_expz%mpc, mpnw) 
 
6233
    call mpmul (q1%mpr, q3%mpr, mp_expz%mpc(mp41), mpnw) 
 
6234
    return
 
6235
  end function
 
6236
 
 
6237
  function mp_imag (za)
 
6238
    implicit real*8 (d), type (mp_integer) (j), &
 
6239
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6240
    type (mp_real):: mp_imag
 
6241
    intent (in):: za
 
6242
    integer mpnw
 
6243
    mpnw = mpnwx
 
6244
    call mpeq (za%mpc(mp41), mp_imag%mpr, mpnw) 
 
6245
    return
 
6246
  end function
 
6247
 
 
6248
  function mp_jtoi (ja)
 
6249
    implicit real*8 (d), type (mp_integer) (j), &
 
6250
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6251
    integer:: mp_jtoi
 
6252
    intent (in):: ja
 
6253
    integer mpnw
 
6254
    mpnw = mpnwx
 
6255
    call mpmdc (ja%mpi, da, ia)
 
6256
    mp_jtoi = da * 2.d0 ** ia
 
6257
    return
 
6258
  end function
 
6259
 
 
6260
  function mp_qtoi (qa)
 
6261
    implicit real*8 (d), type (mp_integer) (j), &
 
6262
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6263
    integer:: mp_qtoi
 
6264
    intent (in):: qa
 
6265
    integer mpnw
 
6266
    mpnw = mpnwx
 
6267
    call mpmdc (qa%mpr, da, ia)
 
6268
    mp_qtoi = da * 2.d0 ** ia
 
6269
    return
 
6270
  end function
 
6271
 
 
6272
  function mp_ztoi (za)
 
6273
    implicit real*8 (d), type (mp_integer) (j), &
 
6274
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6275
    integer:: mp_ztoi
 
6276
    intent (in):: za
 
6277
    integer mpnw
 
6278
    mpnw = mpnwx
 
6279
    call mpmdc (za%mpc, da, ia)
 
6280
    mp_ztoi = da * 2.d0 ** ia
 
6281
    return
 
6282
  end function
 
6283
 
 
6284
  function mp_log (qa)
 
6285
    implicit real*8 (d), type (mp_integer) (j), &
 
6286
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6287
    type (mp_real):: mp_log
 
6288
    intent (in):: qa
 
6289
    integer mpnw
 
6290
    mpnw = mpnwx
 
6291
    call mplog (qa%mpr, mpl02%mpr, mp_log%mpr, mpnw) 
 
6292
    return
 
6293
  end function
 
6294
 
 
6295
  function mp_logz (za)
 
6296
    implicit real*8 (d), type (mp_integer) (j), &
 
6297
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6298
    type (mp_complex):: mp_logz
 
6299
    intent (in):: za
 
6300
    type (mp_real) q1, q2, q3, q4
 
6301
    integer mpnw
 
6302
    mpnw = mpnwx
 
6303
    call mpmul (za%mpc, za%mpc, q1%mpr, mpnw) 
 
6304
    call mpmul (za%mpc(mp41), za%mpc(mp41), q2%mpr, mpnw) 
 
6305
    call mpadd (q1%mpr, q2%mpr, q3%mpr, mpnw) 
 
6306
    call mplog (q3%mpr, mpl02%mpr, q4%mpr, mpnw) 
 
6307
    call mpmuld (q4%mpr, 0.5d0, 0, mp_logz%mpc, mpnw) 
 
6308
    call mpang (za%mpc, za%mpc(mp41), mppic%mpr, mp_logz%mpc(mp41), mpnw) 
 
6309
    return
 
6310
  end function
 
6311
 
 
6312
  function mp_log10 (qa)
 
6313
    implicit real*8 (d), type (mp_integer) (j), &
 
6314
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6315
    type (mp_real):: mp_log10
 
6316
    intent (in):: qa
 
6317
    type (mp_real) q1
 
6318
    integer mpnw
 
6319
    mpnw = mpnwx
 
6320
    call mplog (qa%mpr, mpl02%mpr, q1%mpr, mpnw) 
 
6321
    call mpdiv (q1%mpr, mpl10%mpr, mp_log10%mpr, mpnw) 
 
6322
    return
 
6323
  end function
 
6324
 
 
6325
  function mp_maxj (ja, jb)
 
6326
    implicit real*8 (d), type (mp_integer) (j), &
 
6327
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6328
    type (mp_integer):: mp_maxj
 
6329
    intent (in):: ja, jb
 
6330
    integer mpnw
 
6331
    mpnw = mpnwx
 
6332
    call mpcpr (ja%mpi, jb%mpi, ic, mpnw) 
 
6333
    if (ic .ge. 0) then
 
6334
      call mpeq (ja%mpi, mp_maxj%mpi, mpnw) 
 
6335
    else
 
6336
      call mpeq (jb%mpi, mp_maxj%mpi, mpnw) 
 
6337
    endif
 
6338
    return
 
6339
  end function
 
6340
 
 
6341
  function mp_maxq (qa, qb)
 
6342
    implicit real*8 (d), type (mp_integer) (j), &
 
6343
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6344
    type (mp_real):: mp_maxq
 
6345
    intent (in):: qa, qb
 
6346
    integer mpnw
 
6347
    mpnw = mpnwx
 
6348
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
6349
    if (ic .ge. 0) then
 
6350
      call mpeq (qa%mpr, mp_maxq%mpr, mpnw) 
 
6351
    else
 
6352
      call mpeq (qb%mpr, mp_maxq%mpr, mpnw) 
 
6353
    endif
 
6354
    return
 
6355
  end function
 
6356
 
 
6357
  function mp_maxq3 (qa, qb, qc)
 
6358
    implicit real*8 (d), type (mp_integer) (j), &
 
6359
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6360
    type (mp_real):: mp_maxq3
 
6361
    intent (in):: qa, qb, qc
 
6362
    type (mp_real) q1
 
6363
    integer mpnw
 
6364
    mpnw = mpnwx
 
6365
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
6366
    if (ic .ge. 0) then
 
6367
      call mpeq (qa%mpr, q1%mpr, mpnw) 
 
6368
    else
 
6369
      call mpeq (qb%mpr, q1%mpr, mpnw) 
 
6370
    endif
 
6371
    call mpcpr (q1%mpr, qc%mpr, ic, mpnw) 
 
6372
    if (ic .ge. 0) then
 
6373
      call mpeq (q1%mpr, mp_maxq3%mpr, mpnw) 
 
6374
    else
 
6375
      call mpeq (qc%mpr, mp_maxq3%mpr, mpnw) 
 
6376
    endif
 
6377
    return
 
6378
  end function
 
6379
 
 
6380
  function mp_minj (ja, jb)
 
6381
    implicit real*8 (d), type (mp_integer) (j), &
 
6382
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6383
    type (mp_integer):: mp_minj
 
6384
    intent (in):: ja, jb
 
6385
    integer mpnw
 
6386
    mpnw = mpnwx
 
6387
    call mpcpr (ja%mpi, jb%mpi, ic, mpnw) 
 
6388
    if (ic .lt. 0) then
 
6389
      call mpeq (ja%mpi, mp_minj%mpi, mpnw) 
 
6390
    else
 
6391
      call mpeq (jb%mpi, mp_minj%mpi, mpnw) 
 
6392
    endif
 
6393
    return
 
6394
  end function
 
6395
 
 
6396
  function mp_minq (qa, qb)
 
6397
    implicit real*8 (d), type (mp_integer) (j), &
 
6398
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6399
    type (mp_real):: mp_minq
 
6400
    intent (in):: qa, qb
 
6401
    integer mpnw
 
6402
    mpnw = mpnwx
 
6403
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
6404
    if (ic .lt. 0) then
 
6405
      call mpeq (qa%mpr, mp_minq%mpr, mpnw) 
 
6406
    else
 
6407
      call mpeq (qb%mpr, mp_minq%mpr, mpnw) 
 
6408
    endif
 
6409
    return
 
6410
  end function
 
6411
 
 
6412
  function mp_minq3 (qa, qb, qc)
 
6413
    implicit real*8 (d), type (mp_integer) (j), &
 
6414
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6415
    type (mp_real):: mp_minq3
 
6416
    intent (in):: qa, qb, qc
 
6417
    type (mp_real) q1
 
6418
    integer mpnw
 
6419
    mpnw = mpnwx
 
6420
    call mpcpr (qa%mpr, qb%mpr, ic, mpnw) 
 
6421
    if (ic .lt. 0) then
 
6422
      call mpeq (qa%mpr, q1%mpr, mpnw) 
 
6423
    else
 
6424
      call mpeq (qb%mpr, q1%mpr, mpnw) 
 
6425
    endif
 
6426
    call mpcpr (q1%mpr, qc%mpr, ic, mpnw) 
 
6427
    if (ic .lt. 0) then
 
6428
      call mpeq (q1%mpr, mp_minq3%mpr, mpnw) 
 
6429
    else
 
6430
      call mpeq (qc%mpr, mp_minq3%mpr, mpnw) 
 
6431
    endif
 
6432
    return
 
6433
  end function
 
6434
 
 
6435
  function mp_modj (ja, jb)
 
6436
    implicit real*8 (d), type (mp_integer) (j), &
 
6437
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6438
    type (mp_integer):: mp_modj
 
6439
    intent (in):: ja, jb
 
6440
    type (mp_real) q1, q2, q3
 
6441
    integer mpnw
 
6442
    mpnw = mpnwx
 
6443
    call mpdiv (ja%mpi, jb%mpi, q1%mpr, mpnw) 
 
6444
    call mpinfr (q1%mpr, q2%mpr, q3%mpr, mpnw) 
 
6445
    call mpmul (jb%mpi, q2%mpr, q1%mpr, mpnw) 
 
6446
    call mpsub (ja%mpi, q1%mpr, mp_modj%mpi, mpnw) 
 
6447
    return
 
6448
  end function
 
6449
 
 
6450
  function mp_modq (qa, qb)
 
6451
    implicit real*8 (d), type (mp_integer) (j), &
 
6452
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6453
    type (mp_real):: mp_modq
 
6454
    intent (in):: qa, qb
 
6455
    type (mp_real) q1, q2, q3
 
6456
    integer mpnw
 
6457
    mpnw = mpnwx
 
6458
    call mpdiv (qa%mpr, qb%mpr, q1%mpr, mpnw) 
 
6459
    call mpinfr (q1%mpr, q2%mpr, q3%mpr, mpnw) 
 
6460
    call mpmul (qb%mpr, q2%mpr, q1%mpr, mpnw) 
 
6461
    call mpsub (qa%mpr, q1%mpr, mp_modq%mpr, mpnw) 
 
6462
    return
 
6463
  end function
 
6464
 
 
6465
  function mp_jtoz (ja)
 
6466
    implicit real*8 (d), type (mp_integer) (j), &
 
6467
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6468
    type (mp_complex):: mp_jtoz
 
6469
    intent (in):: ja
 
6470
    integer mpnw
 
6471
    mpnw = mpnwx
 
6472
    call mpmzc (ja%mpi, mp_jtoz%mpc)
 
6473
    return
 
6474
  end function
 
6475
 
 
6476
  function mp_qtoz (qa)
 
6477
    implicit real*8 (d), type (mp_integer) (j), &
 
6478
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6479
    type (mp_complex):: mp_qtoz
 
6480
    intent (in):: qa
 
6481
    integer mpnw
 
6482
    mpnw = mpnwx
 
6483
    call mpmzc (qa%mpr, mp_qtoz%mpc)
 
6484
    return
 
6485
  end function
 
6486
 
 
6487
  function mp_itoz (ia)
 
6488
    implicit real*8 (d), type (mp_integer) (j), &
 
6489
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6490
    type (mp_complex):: mp_itoz
 
6491
    intent (in):: ia
 
6492
    integer mpnw
 
6493
    mpnw = mpnwx
 
6494
    xa = ia
 
6495
    call mpxzc (xa, mp_itoz%mpc)
 
6496
    return
 
6497
  end function
 
6498
 
 
6499
  function mp_rtoz (ra)
 
6500
    implicit real*8 (d), type (mp_integer) (j), &
 
6501
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6502
    type (mp_complex):: mp_rtoz
 
6503
    intent (in):: ra
 
6504
    integer mpnw
 
6505
    mpnw = mpnwx
 
6506
    xa = ra
 
6507
    call mpxzc (xa, mp_rtoz%mpc)
 
6508
    return
 
6509
  end function
 
6510
 
 
6511
  function mp_ctoz (ca)
 
6512
    implicit real*8 (d), type (mp_integer) (j), &
 
6513
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6514
    type (mp_complex):: mp_ctoz
 
6515
    intent (in):: ca
 
6516
    integer mpnw
 
6517
    mpnw = mpnwx
 
6518
    xa = ca
 
6519
    call mpxzc (xa, mp_ctoz%mpc)
 
6520
    return
 
6521
  end function
 
6522
 
 
6523
  function mp_dtoz (da)
 
6524
    implicit real*8 (d), type (mp_integer) (j), &
 
6525
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6526
    type (mp_complex):: mp_dtoz
 
6527
    intent (in):: da
 
6528
    integer mpnw
 
6529
    mpnw = mpnwx
 
6530
    xa = da
 
6531
    call mpxzc (xa, mp_dtoz%mpc)
 
6532
    return
 
6533
  end function
 
6534
 
 
6535
  function mp_xtoz (xa)
 
6536
    implicit real*8 (d), type (mp_integer) (j), &
 
6537
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6538
    type (mp_complex):: mp_xtoz
 
6539
    intent (in):: xa
 
6540
    integer mpnw
 
6541
    mpnw = mpnwx
 
6542
    call mpxzc (xa, mp_xtoz%mpc)
 
6543
    return
 
6544
  end function
 
6545
 
 
6546
  function mp_atoz (aa)
 
6547
    implicit real*8 (d), type (mp_integer) (j), &
 
6548
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6549
    character*(*), intent (in):: aa
 
6550
    type (mp_complex):: mp_atoz
 
6551
    character*1 az(mpipl+100)
 
6552
    type (mp_real) q1
 
6553
    integer mpnw
 
6554
    mpnw = mpnwx
 
6555
    l = len (aa)
 
6556
    do i = 1, l
 
6557
      az(i) = aa(i:i)
 
6558
    enddo
 
6559
    call mpinpc (az, l, q1%mpr, mpnw) 
 
6560
    call mpmzc (q1%mpr, mp_atoz%mpc)
 
6561
    return
 
6562
  end function
 
6563
 
 
6564
  function mp_jjtoz (ja, jb)
 
6565
    implicit real*8 (d), type (mp_integer) (j), &
 
6566
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6567
    type (mp_complex):: mp_jjtoz
 
6568
    intent (in):: ja, jb
 
6569
    integer mpnw
 
6570
    mpnw = mpnwx
 
6571
    call mpmmpc (ja%mpi, jb%mpi, mp4, mp_jjtoz%mpc, mpnw) 
 
6572
    return
 
6573
  end function
 
6574
 
 
6575
  function mp_qqtoz (qa, qb)
 
6576
    implicit real*8 (d), type (mp_integer) (j), &
 
6577
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6578
    type (mp_complex):: mp_qqtoz
 
6579
    intent (in):: qa, qb
 
6580
    integer mpnw
 
6581
    mpnw = mpnwx
 
6582
    call mpmmpc (qa%mpr, qb%mpr, mp4, mp_qqtoz%mpc, mpnw) 
 
6583
    return
 
6584
  end function
 
6585
 
 
6586
  function mp_iitoz (ia, ib)
 
6587
    implicit real*8 (d), type (mp_integer) (j), &
 
6588
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6589
    type (mp_complex):: mp_iitoz
 
6590
    intent (in):: ia, ib
 
6591
    integer mpnw
 
6592
    mpnw = mpnwx
 
6593
    xa = cmplx (ia, ib, kdb)
 
6594
    call mpxzc (xa, mp_iitoz%mpc)
 
6595
    return
 
6596
  end function
 
6597
 
 
6598
  function mp_ddtoz (da, db)
 
6599
    implicit real*8 (d), type (mp_integer) (j), &
 
6600
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6601
    type (mp_complex):: mp_ddtoz
 
6602
    intent (in):: da, db
 
6603
    integer mpnw
 
6604
    mpnw = mpnwx
 
6605
    xa = cmplx (da, db, kdb)
 
6606
    call mpxzc (xa, mp_ddtoz%mpc)
 
6607
    return
 
6608
  end function
 
6609
 
 
6610
  function mp_aatoz (aa, ab)
 
6611
    implicit real*8 (d), type (mp_integer) (j), &
 
6612
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6613
    character*(*), intent (in):: aa, ab
 
6614
    type (mp_complex):: mp_aatoz
 
6615
    character*1 az(mpipl+100)
 
6616
    integer mpnw
 
6617
    mpnw = mpnwx
 
6618
    l = len (aa)
 
6619
    do i = 1, l
 
6620
      az(i) = aa(i:i)
 
6621
    enddo
 
6622
    call mpinpc (az, l, mp_aatoz%mpc, mpnw) 
 
6623
    l = len (ab)
 
6624
    do i = 1, l
 
6625
      az(i) = ab(i:i)
 
6626
    enddo
 
6627
    call mpinpc (az, l, mp_aatoz%mpc(mp41), mpnw) 
 
6628
    return
 
6629
  end function
 
6630
 
 
6631
  subroutine mp_cssh (qa, qb, qc)
 
6632
    implicit real*8 (d), type (mp_integer) (j), &
 
6633
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6634
    intent (in):: qa
 
6635
    intent (out):: qb, qc
 
6636
    integer mpnw
 
6637
    mpnw = mpnwx
 
6638
    call mpcssh (qa%mpr, mpl02%mpr, qb%mpr, qc%mpr, mpnw) 
 
6639
    return
 
6640
  end subroutine
 
6641
 
 
6642
  subroutine mp_cssn (qa, qb, qc)
 
6643
    implicit real*8 (d), type (mp_integer) (j), &
 
6644
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6645
    intent (in):: qa
 
6646
    intent (out):: qb, qc
 
6647
    integer mpnw
 
6648
    mpnw = mpnwx
 
6649
    call mpcssn (qa%mpr, mppic%mpr, qb%mpr, qc%mpr, mpnw) 
 
6650
    return
 
6651
  end subroutine
 
6652
 
 
6653
  function mp_qtoj (qa)
 
6654
    implicit real*8 (d), type (mp_integer) (j), &
 
6655
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6656
    type (mp_integer):: mp_qtoj
 
6657
    intent (in):: qa
 
6658
    type (mp_real) q1, q2
 
6659
    integer mpnw
 
6660
    mpnw = mpnwx
 
6661
    call mpeq (qa%mpr, q1%mpr, mpnw) 
 
6662
    call mpinfr (q1%mpr, mp_qtoj%mpi, q2%mpr, mpnw) 
 
6663
    return
 
6664
  end function
 
6665
 
 
6666
  function mp_ztoj (za)
 
6667
    implicit real*8 (d), type (mp_integer) (j), &
 
6668
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6669
    type (mp_integer):: mp_ztoj
 
6670
    intent (in):: za
 
6671
    type (mp_real) q1, q2
 
6672
    integer mpnw
 
6673
    mpnw = mpnwx
 
6674
    call mpeq (za%mpc, q1%mpr, mpnw) 
 
6675
    call mpinfr (q1%mpr, mp_ztoj%mpi, q2%mpr, mpnw) 
 
6676
    return
 
6677
  end function
 
6678
 
 
6679
  function mp_itoj (ia)
 
6680
    implicit real*8 (d), type (mp_integer) (j), &
 
6681
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6682
    type (mp_integer):: mp_itoj
 
6683
    intent (in):: ia
 
6684
    integer mpnw
 
6685
    mpnw = mpnwx
 
6686
    da = ia
 
6687
    call mpdmc (da, 0, mp_itoj%mpi)
 
6688
    return
 
6689
  end function
 
6690
 
 
6691
  function mp_dtoj (da)
 
6692
    implicit real*8 (d), type (mp_integer) (j), &
 
6693
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6694
    type (mp_integer):: mp_dtoj
 
6695
    intent (in):: da
 
6696
    type (mp_real) q1, q2
 
6697
    integer mpnw
 
6698
    mpnw = mpnwx
 
6699
    call mpdmc (da, 0, q1%mpr)
 
6700
    call mpinfr (q1%mpr, mp_dtoj%mpi, q2%mpr, mpnw) 
 
6701
    return
 
6702
  end function
 
6703
 
 
6704
  function mp_xtoj (xa)
 
6705
    implicit real*8 (d), type (mp_integer) (j), &
 
6706
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6707
    type (mp_integer):: mp_xtoj
 
6708
    intent (in):: xa
 
6709
    type (mp_real) q1, q2
 
6710
    integer mpnw
 
6711
    mpnw = mpnwx
 
6712
    da = xa
 
6713
    call mpdmc (da, 0, q1%mpr)
 
6714
    call mpinfr (q1%mpr, mp_xtoj%mpi, q2%mpr, mpnw) 
 
6715
    return
 
6716
  end function
 
6717
 
 
6718
  function mp_atoj (aa)
 
6719
    implicit real*8 (d), type (mp_integer) (j), &
 
6720
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6721
    character*(*), intent (in):: aa
 
6722
    type (mp_integer):: mp_atoj
 
6723
    character*1 az(mpipl+100)
 
6724
    type (mp_real) q1, q2
 
6725
    integer mpnw
 
6726
    mpnw = mpnwx
 
6727
    l = len (aa)
 
6728
    do i = 1, l
 
6729
      az(i) = aa(i:i)
 
6730
    enddo
 
6731
    call mpinpc (az, l, q1%mpr, mpnw) 
 
6732
    call mpinfr (q1%mpr, mp_atoj%mpi, q2%mpr, mpnw) 
 
6733
    return
 
6734
  end function
 
6735
 
 
6736
  function mp_nrt (qa, ib)
 
6737
    implicit real*8 (d), type (mp_integer) (j), &
 
6738
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6739
    type (mp_real):: mp_nrt
 
6740
    intent (in):: qa, ib
 
6741
    integer mpnw
 
6742
    mpnw = mpnwx
 
6743
    call mpnrt (qa%mpr, ib, mp_nrt%mpr, mpnw) 
 
6744
    return
 
6745
  end function
 
6746
 
 
6747
  function mp_rand ()
 
6748
    implicit real*8 (d), type (mp_integer) (j), &
 
6749
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6750
    type (mp_real):: mp_rand
 
6751
    integer mpnw
 
6752
    mpnw = mpnwx
 
6753
    call mprand (mp_rand%mpr, mpnw) 
 
6754
    return
 
6755
  end function
 
6756
 
 
6757
  subroutine mp_inpj (iu, j1, j2, j3, j4, j5, j6, j7, j8, j9)
 
6758
    implicit real*8 (d), type (mp_integer) (j), &
 
6759
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6760
    intent (out):: j1, j2, j3, j4, j5, j6, j7, j8, j9
 
6761
    optional:: j2, j3, j4, j5, j6, j7, j8, j9
 
6762
    character*1 az(mpipl+100)
 
6763
    integer mpnw
 
6764
    mpnw = mpnwx
 
6765
    call mpinp (iu, j1%mpi, az, mpnw) 
 
6766
    if (present (j2)) call mpinp (iu, j2%mpi, az, mpnw) 
 
6767
    if (present (j3)) call mpinp (iu, j3%mpi, az, mpnw) 
 
6768
    if (present (j4)) call mpinp (iu, j4%mpi, az, mpnw) 
 
6769
    if (present (j5)) call mpinp (iu, j5%mpi, az, mpnw) 
 
6770
    if (present (j6)) call mpinp (iu, j6%mpi, az, mpnw) 
 
6771
    if (present (j7)) call mpinp (iu, j7%mpi, az, mpnw) 
 
6772
    if (present (j8)) call mpinp (iu, j8%mpi, az, mpnw) 
 
6773
    if (present (j9)) call mpinp (iu, j9%mpi, az, mpnw) 
 
6774
    return
 
6775
  end subroutine
 
6776
 
 
6777
  subroutine mp_inpq (iu, q1, q2, q3, q4, q5, q6, q7, q8, q9)
 
6778
    implicit real*8 (d), type (mp_integer) (j), &
 
6779
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6780
    intent (out):: q1, q2, q3, q4, q5, q6, q7, q8, q9
 
6781
    optional:: q2, q3, q4, q5, q6, q7, q8, q9
 
6782
    character*1 az(mpipl+100)
 
6783
    integer mpnw
 
6784
    mpnw = mpnwx
 
6785
    call mpinp (iu, q1%mpr, az, mpnw) 
 
6786
    if (present (q2)) call mpinp (iu, q2%mpr, az, mpnw) 
 
6787
    if (present (q3)) call mpinp (iu, q3%mpr, az, mpnw) 
 
6788
    if (present (q4)) call mpinp (iu, q4%mpr, az, mpnw) 
 
6789
    if (present (q5)) call mpinp (iu, q5%mpr, az, mpnw) 
 
6790
    if (present (q6)) call mpinp (iu, q6%mpr, az, mpnw) 
 
6791
    if (present (q7)) call mpinp (iu, q7%mpr, az, mpnw) 
 
6792
    if (present (q8)) call mpinp (iu, q8%mpr, az, mpnw) 
 
6793
    if (present (q9)) call mpinp (iu, q9%mpr, az, mpnw) 
 
6794
    return
 
6795
  end subroutine
 
6796
 
 
6797
  subroutine mp_inpz (iu, z1, z2, z3, z4, z5, z6, z7, z8, z9)
 
6798
    implicit real*8 (d), type (mp_integer) (j), &
 
6799
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6800
    intent (out):: z1, z2, z3, z4, z5, z6, z7, z8, z9
 
6801
    optional:: z2, z3, z4, z5, z6, z7, z8, z9
 
6802
    character*1 az(mpipl+100)
 
6803
    integer mpnw
 
6804
    mpnw = mpnwx
 
6805
    call mpinp (iu, z1%mpc, az, mpnw) 
 
6806
    call mpinp (iu, z1%mpc(mp41), az, mpnw) 
 
6807
    if (present (z2)) call mpinp (iu, z2%mpc, az, mpnw) 
 
6808
    if (present (z2)) call mpinp (iu, z2%mpc(mp41), az, mpnw) 
 
6809
    if (present (z3)) call mpinp (iu, z3%mpc, az, mpnw) 
 
6810
    if (present (z3)) call mpinp (iu, z3%mpc(mp41), az, mpnw) 
 
6811
    if (present (z4)) call mpinp (iu, z4%mpc, az, mpnw) 
 
6812
    if (present (z4)) call mpinp (iu, z4%mpc(mp41), az, mpnw) 
 
6813
    if (present (z5)) call mpinp (iu, z5%mpc, az, mpnw) 
 
6814
    if (present (z5)) call mpinp (iu, z5%mpc(mp41), az, mpnw) 
 
6815
    if (present (z6)) call mpinp (iu, z6%mpc, az, mpnw) 
 
6816
    if (present (z6)) call mpinp (iu, z6%mpc(mp41), az, mpnw) 
 
6817
    if (present (z7)) call mpinp (iu, z7%mpc, az, mpnw) 
 
6818
    if (present (z7)) call mpinp (iu, z7%mpc(mp41), az, mpnw) 
 
6819
    if (present (z8)) call mpinp (iu, z8%mpc, az, mpnw) 
 
6820
    if (present (z8)) call mpinp (iu, z8%mpc(mp41), az, mpnw) 
 
6821
    if (present (z9)) call mpinp (iu, z9%mpc, az, mpnw) 
 
6822
    if (present (z9)) call mpinp (iu, z9%mpc(mp41), az, mpnw) 
 
6823
    return
 
6824
  end subroutine
 
6825
 
 
6826
  function mp_jtoq (ja)
 
6827
    implicit real*8 (d), type (mp_integer) (j), &
 
6828
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6829
    type (mp_real):: mp_jtoq
 
6830
    intent (in):: ja
 
6831
    integer mpnw
 
6832
    mpnw = mpnwx
 
6833
    call mpeq (ja%mpi, mp_jtoq%mpr, mpnw) 
 
6834
    return
 
6835
  end function
 
6836
 
 
6837
  function mp_ztoq (za)
 
6838
    implicit real*8 (d), type (mp_integer) (j), &
 
6839
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6840
    type (mp_real):: mp_ztoq
 
6841
    intent (in):: za
 
6842
    integer mpnw
 
6843
    mpnw = mpnwx
 
6844
    call mpeq (za%mpc, mp_ztoq%mpr, mpnw) 
 
6845
    return
 
6846
  end function
 
6847
 
 
6848
  function mp_itoq (ia)
 
6849
    implicit real*8 (d), type (mp_integer) (j), &
 
6850
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6851
    type (mp_real):: mp_itoq
 
6852
    intent (in):: ia
 
6853
    integer mpnw
 
6854
    mpnw = mpnwx
 
6855
    da = ia
 
6856
    call mpdmc (da, 0, mp_itoq%mpr)
 
6857
    return
 
6858
  end function
 
6859
 
 
6860
  function mp_dtoq (da)
 
6861
    implicit real*8 (d), type (mp_integer) (j), &
 
6862
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6863
    type (mp_real):: mp_dtoq
 
6864
    intent (in):: da
 
6865
    integer mpnw
 
6866
    mpnw = mpnwx
 
6867
    call mpdmc (da, 0, mp_dtoq%mpr)
 
6868
    return
 
6869
  end function
 
6870
 
 
6871
  function mp_xtoq (xa)
 
6872
    implicit real*8 (d), type (mp_integer) (j), &
 
6873
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6874
    type (mp_real):: mp_xtoq
 
6875
    intent (in):: xa
 
6876
    integer mpnw
 
6877
    mpnw = mpnwx
 
6878
    da = xa
 
6879
    call mpdmc (da, 0, mp_xtoq%mpr)
 
6880
    return
 
6881
  end function
 
6882
 
 
6883
  function mp_atoq (aa)
 
6884
    implicit real*8 (d), type (mp_integer) (j), &
 
6885
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6886
    character*(*), intent (in):: aa
 
6887
    type (mp_real):: mp_atoq
 
6888
    character*1 az(mpipl+100)
 
6889
    integer mpnw
 
6890
    mpnw = mpnwx
 
6891
    l = len (aa)
 
6892
    do i = 1, l
 
6893
      az(i) = aa(i:i)
 
6894
    enddo
 
6895
    call mpdexc (az, l, mp_atoq%mpr, mpnw) 
 
6896
    return
 
6897
  end function
 
6898
 
 
6899
  subroutine mp_outj (iu, j1, j2, j3, j4, j5, j6, j7, j8, j9)
 
6900
    implicit real*8 (d), type (mp_integer) (j), &
 
6901
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6902
    intent (in):: j1, j2, j3, j4, j5, j6, j7, j8, j9
 
6903
    optional:: j2, j3, j4, j5, j6, j7, j8, j9
 
6904
    character*1 az(mpipl+100)
 
6905
    integer mpnw
 
6906
    mpnw = mpnwx
 
6907
    call mpout (iu, j1%mpi, mpoud, az, mpnw) 
 
6908
    if (present (j2)) call mpout (iu, j2%mpi, mpoud, az, mpnw) 
 
6909
    if (present (j3)) call mpout (iu, j3%mpi, mpoud, az, mpnw) 
 
6910
    if (present (j4)) call mpout (iu, j4%mpi, mpoud, az, mpnw) 
 
6911
    if (present (j5)) call mpout (iu, j5%mpi, mpoud, az, mpnw) 
 
6912
    if (present (j6)) call mpout (iu, j6%mpi, mpoud, az, mpnw) 
 
6913
    if (present (j7)) call mpout (iu, j7%mpi, mpoud, az, mpnw) 
 
6914
    if (present (j8)) call mpout (iu, j8%mpi, mpoud, az, mpnw) 
 
6915
    if (present (j9)) call mpout (iu, j9%mpi, mpoud, az, mpnw) 
 
6916
     return
 
6917
  end subroutine
 
6918
 
 
6919
  subroutine mp_outq (iu, q1, q2, q3, q4, q5, q6, q7, q8, q9)
 
6920
    implicit real*8 (d), type (mp_integer) (j), &
 
6921
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6922
    intent (in):: q1, q2, q3, q4, q5, q6, q7, q8, q9
 
6923
    optional:: q2, q3, q4, q5, q6, q7, q8, q9
 
6924
    character*1 az(mpipl+100)
 
6925
    integer mpnw
 
6926
    mpnw = mpnwx
 
6927
    call mpout (iu, q1%mpr, mpoud, az, mpnw) 
 
6928
    if (present (q2)) call mpout (iu, q2%mpr, mpoud, az, mpnw) 
 
6929
    if (present (q3)) call mpout (iu, q3%mpr, mpoud, az, mpnw) 
 
6930
    if (present (q4)) call mpout (iu, q4%mpr, mpoud, az, mpnw) 
 
6931
    if (present (q5)) call mpout (iu, q5%mpr, mpoud, az, mpnw) 
 
6932
    if (present (q6)) call mpout (iu, q6%mpr, mpoud, az, mpnw) 
 
6933
    if (present (q7)) call mpout (iu, q7%mpr, mpoud, az, mpnw) 
 
6934
    if (present (q8)) call mpout (iu, q8%mpr, mpoud, az, mpnw) 
 
6935
    if (present (q9)) call mpout (iu, q9%mpr, mpoud, az, mpnw) 
 
6936
     return
 
6937
  end subroutine
 
6938
 
 
6939
  subroutine mp_outz (iu, z1, z2, z3, z4, z5, z6, z7, z8, z9)
 
6940
    implicit real*8 (d), type (mp_integer) (j), &
 
6941
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6942
    intent (in):: z1, z2, z3, z4, z5, z6, z7, z8, z9
 
6943
    optional:: z2, z3, z4, z5, z6, z7, z8, z9
 
6944
    character*1 az(mpipl+100)
 
6945
    integer mpnw
 
6946
    mpnw = mpnwx
 
6947
    call mpout (iu, z1%mpc, mpoud, az, mpnw) 
 
6948
    call mpout (iu, z1%mpc(mp41), mpoud, az, mpnw) 
 
6949
    if (present (z2)) call mpout (iu, z2%mpc, mpoud, az, mpnw) 
 
6950
    if (present (z2)) call mpout (iu, z2%mpc(mp41), mpoud, az, mpnw) 
 
6951
    if (present (z3)) call mpout (iu, z3%mpc, mpoud, az, mpnw) 
 
6952
    if (present (z3)) call mpout (iu, z3%mpc(mp41), mpoud, az, mpnw) 
 
6953
    if (present (z4)) call mpout (iu, z4%mpc, mpoud, az, mpnw) 
 
6954
    if (present (z4)) call mpout (iu, z4%mpc(mp41), mpoud, az, mpnw) 
 
6955
    if (present (z5)) call mpout (iu, z5%mpc, mpoud, az, mpnw) 
 
6956
    if (present (z5)) call mpout (iu, z5%mpc(mp41), mpoud, az, mpnw) 
 
6957
    if (present (z6)) call mpout (iu, z6%mpc, mpoud, az, mpnw) 
 
6958
    if (present (z6)) call mpout (iu, z6%mpc(mp41), mpoud, az, mpnw) 
 
6959
    if (present (z7)) call mpout (iu, z7%mpc, mpoud, az, mpnw) 
 
6960
    if (present (z7)) call mpout (iu, z7%mpc(mp41), mpoud, az, mpnw) 
 
6961
    if (present (z8)) call mpout (iu, z8%mpc, mpoud, az, mpnw) 
 
6962
    if (present (z8)) call mpout (iu, z8%mpc(mp41), mpoud, az, mpnw) 
 
6963
    if (present (z9)) call mpout (iu, z9%mpc, mpoud, az, mpnw) 
 
6964
    if (present (z9)) call mpout (iu, z9%mpc(mp41), mpoud, az, mpnw) 
 
6965
     return
 
6966
  end subroutine
 
6967
 
 
6968
  function mp_nint (qa)
 
6969
    implicit real*8 (d), type (mp_integer) (j), &
 
6970
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6971
    type (mp_integer):: mp_nint
 
6972
    intent (in):: qa
 
6973
    integer mpnw
 
6974
    mpnw = mpnwx
 
6975
    call mpnint (qa%mpr, mp_nint%mpi, mpnw) 
 
6976
    return
 
6977
  end function
 
6978
 
 
6979
  function mp_ztor (za)
 
6980
    implicit real*8 (d), type (mp_integer) (j), &
 
6981
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6982
    intent (in):: za
 
6983
    real:: mp_ztor
 
6984
    integer mpnw
 
6985
    mpnw = mpnwx
 
6986
    call mpmdc (za%mpc, da, ia)
 
6987
    mp_ztor = da * 2.d0 ** ia
 
6988
    return
 
6989
  end function
 
6990
 
 
6991
  function mp_signj (ja, jb)
 
6992
    implicit real*8 (d), type (mp_integer) (j), &
 
6993
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
6994
    type (mp_integer):: mp_signj
 
6995
    intent (in):: ja, jb
 
6996
    integer mpnw
 
6997
    mpnw = mpnwx
 
6998
    call mpeq (ja%mpi, mp_signj%mpi, mpnw) 
 
6999
    mp_signj%mpi(1) = sign (mp_signj%mpi(1), jb%mpi(1))
 
7000
    return
 
7001
  end function
 
7002
 
 
7003
  function mp_signq (qa, qb)
 
7004
    implicit real*8 (d), type (mp_integer) (j), &
 
7005
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7006
    type (mp_real):: mp_signq
 
7007
    intent (in):: qa, qb
 
7008
    integer mpnw
 
7009
    mpnw = mpnwx
 
7010
    call mpeq (qa%mpr, mp_signq%mpr, mpnw) 
 
7011
    mp_signq%mpr(1) = sign (mp_signq%mpr(1), qb%mpr(1))
 
7012
    return
 
7013
  end function
 
7014
 
 
7015
  function mp_sin (qa)
 
7016
    implicit real*8 (d), type (mp_integer) (j), &
 
7017
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7018
    type (mp_real):: mp_sin
 
7019
    intent (in):: qa
 
7020
    type (mp_real) q1
 
7021
    integer mpnw
 
7022
    mpnw = mpnwx
 
7023
    call mpcssn (qa%mpr, mppic%mpr, q1%mpr, mp_sin%mpr, mpnw) 
 
7024
    return
 
7025
  end function
 
7026
 
 
7027
  function mp_sinz (za)
 
7028
    implicit real*8 (d), type (mp_integer) (j), &
 
7029
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7030
    type (mp_complex):: mp_sinz
 
7031
    intent (in):: za
 
7032
    type (mp_real) q1, q2, q3, q4, q5, q6
 
7033
    integer mpnw
 
7034
    mpnw = mpnwx
 
7035
    call mpeq (za%mpc(mp41), q2%mpr, mpnw) 
 
7036
    q2%mpr(1) = - q2%mpr(1)
 
7037
    call mpexp (q2%mpr, mpl02%mpr, q1%mpr, mpnw) 
 
7038
    call mpdmc (1.d0, 0, q3%mpr)
 
7039
    call mpdiv (q3%mpr, q1%mpr, q2%mpr, mpnw) 
 
7040
    call mpcssn (za%mpc, mppic%mpr, q3%mpr, q4%mpr, mpnw) 
 
7041
    call mpadd (q1%mpr, q2%mpr, q5%mpr, mpnw) 
 
7042
    call mpmuld (q5%mpr, 0.5d0, 0, q6%mpr, mpnw) 
 
7043
    call mpmul (q6%mpr, q4%mpr, mp_sinz%mpc, mpnw) 
 
7044
    call mpsub (q1%mpr, q2%mpr, q5%mpr, mpnw) 
 
7045
    call mpmuld (q5%mpr, -0.5d0, 0, q6%mpr, mpnw) 
 
7046
    call mpmul (q6%mpr, q3%mpr, mp_sinz%mpc(mp41), mpnw) 
 
7047
    return
 
7048
  end function
 
7049
 
 
7050
  function mp_sinh (qa)
 
7051
    implicit real*8 (d), type (mp_integer) (j), &
 
7052
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7053
    type (mp_real):: mp_sinh
 
7054
    intent (in):: qa
 
7055
    type (mp_real) q1
 
7056
    integer mpnw
 
7057
    mpnw = mpnwx
 
7058
    call mpcssh (qa%mpr, mpl02%mpr, q1%mpr, mp_sinh%mpr, mpnw) 
 
7059
    return
 
7060
  end function
 
7061
 
 
7062
  function mp_sqrtq (qa)
 
7063
    implicit real*8 (d), type (mp_integer) (j), &
 
7064
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7065
    type (mp_real):: mp_sqrtq
 
7066
    intent (in):: qa
 
7067
    integer mpnw
 
7068
    mpnw = mpnwx
 
7069
    call mpsqrt (qa%mpr, mp_sqrtq%mpr, mpnw) 
 
7070
    return
 
7071
  end function
 
7072
 
 
7073
  function mp_sqrtz (za)
 
7074
    implicit real*8 (d), type (mp_integer) (j), &
 
7075
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7076
    type (mp_complex):: mp_sqrtz
 
7077
    intent (in):: za
 
7078
    integer mpnw
 
7079
    mpnw = mpnwx
 
7080
    call mpcsqt (mp4, za%mpc, mp_sqrtz%mpc, mpnw) 
 
7081
    return
 
7082
  end function
 
7083
 
 
7084
  function mp_tan (qa)
 
7085
    implicit real*8 (d), type (mp_integer) (j), &
 
7086
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7087
    type (mp_real):: mp_tan
 
7088
    intent (in):: qa
 
7089
    type (mp_real) q1, q2
 
7090
    integer mpnw
 
7091
    mpnw = mpnwx
 
7092
    call mpcssn (qa%mpr, mppic%mpr, q1%mpr, q2%mpr, mpnw) 
 
7093
    call mpdiv (q2%mpr, q1%mpr, mp_tan%mpr, mpnw) 
 
7094
    return
 
7095
  end function
 
7096
 
 
7097
  function mp_tanh (qa)
 
7098
    implicit real*8 (d), type (mp_integer) (j), &
 
7099
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7100
    type (mp_real):: mp_tanh
 
7101
    intent (in):: qa
 
7102
    type (mp_real) q1, q2
 
7103
    integer mpnw
 
7104
    mpnw = mpnwx
 
7105
    call mpcssh (qa%mpr, mpl02%mpr, q1%mpr, q2%mpr, mpnw) 
 
7106
    call mpdiv (q2%mpr, q1%mpr, mp_tanh%mpr, mpnw) 
 
7107
    return
 
7108
  end function
 
7109
 
 
7110
end module
 
7111
 
 
7112
!   This contains defines bessel, besselexp, erf, erfc and gamma functions.
 
7113
 
 
7114
module mpfunsubmod
 
7115
use mpfunmod
 
7116
use mpdefmod
 
7117
use mprealmod
 
7118
use mpgenmod
 
7119
private mp_bessel, mp_besselexp, mp_erf, mp_erfc, mp_gamma
 
7120
integer, private:: kdb
 
7121
parameter (kdb = kind (0.d0))
 
7122
 
 
7123
interface bessel
 
7124
  module procedure mp_bessel
 
7125
end interface
 
7126
 
 
7127
interface besselexp
 
7128
  module procedure mp_besselexp
 
7129
end interface
 
7130
 
 
7131
interface erf
 
7132
  module procedure mp_erf
 
7133
end interface
 
7134
 
 
7135
interface erfc
 
7136
  module procedure mp_erfc
 
7137
end interface
 
7138
 
 
7139
interface gamma
 
7140
  module procedure mp_gamma
 
7141
end interface
 
7142
 
 
7143
contains
 
7144
 
 
7145
  function mp_bessel (qa)
 
7146
    implicit real*8 (d), type (mp_integer) (j), &
 
7147
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7148
    type (mp_real):: mp_bessel
 
7149
    intent (in):: qa
 
7150
    call mpbessel (qa, mp_bessel)
 
7151
    return
 
7152
  end function
 
7153
 
 
7154
  function mp_besselexp (qa)
 
7155
    implicit real*8 (d), type (mp_integer) (j), &
 
7156
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7157
    type (mp_real):: mp_besselexp
 
7158
    intent (in):: qa
 
7159
    call mpbesselexp (qa, mp_besselexp)
 
7160
    return
 
7161
  end function
 
7162
 
 
7163
  function mp_erf (qa)
 
7164
    implicit real*8 (d), type (mp_integer) (j), &
 
7165
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7166
    type (mp_real):: mp_erf
 
7167
    intent (in):: qa
 
7168
    call mperf (qa, mp_erf)
 
7169
    return
 
7170
  end function
 
7171
 
 
7172
  function mp_erfc (qa)
 
7173
    implicit real*8 (d), type (mp_integer) (j), &
 
7174
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7175
    type (mp_real):: mp_erfc
 
7176
    intent (in):: qa
 
7177
    call mperfc (qa, mp_erfc)
 
7178
    return
 
7179
  end function
 
7180
 
 
7181
  function mp_gamma (qa)
 
7182
    implicit real*8 (d), type (mp_integer) (j), &
 
7183
      type (mp_real) (q), complex (kdb) (x), type (mp_complex) (z)
 
7184
    type (mp_real):: mp_gamma
 
7185
    intent (in):: qa
 
7186
    call mpgamma (qa, mp_gamma)
 
7187
    return
 
7188
  end function
 
7189
 
 
7190
subroutine mpbessel (t, z)
 
7191
 
 
7192
!   This evaluates the function BesselI (0, t).
 
7193
 
 
7194
implicit none
 
7195
integer i, ndp, nwords
 
7196
type (mp_real) eps, tsum, t, t1, t2, z
 
7197
 
 
7198
call mpgetprecwords (nwords)
 
7199
eps = mpreal (2.d0) ** (-48 * nwords - 1)
 
7200
ndp = (nwords - 2) * 7.224719896d0
 
7201
 
 
7202
!   Select either the direct or the asymptotic series.
 
7203
 
 
7204
if (0.85d0 * t < ndp) then
 
7205
  tsum = 1.d0
 
7206
  t1 = 1.d0
 
7207
  t2 = t ** 2
 
7208
 
 
7209
  do i = 1, 1000000000
 
7210
    t1 = t1 * t2 / (4.d0 * dble (i) ** 2)
 
7211
    if (t1 < eps) goto 100
 
7212
    tsum = tsum + t1
 
7213
  enddo
 
7214
 
 
7215
  write (6, *) 'bessel: loop overflow 1'
 
7216
  tsum = 0.d0
 
7217
 
 
7218
100 continue
 
7219
 
 
7220
  t1 = tsum
 
7221
else
 
7222
  tsum = 1.d0
 
7223
  t1 = 1.d0
 
7224
 
 
7225
  do i = 1, 1000000000
 
7226
    t2 = t1
 
7227
    t1 = t1 * (2.d0 * i - 1.d0) ** 2 / (8.d0 * i * t)
 
7228
    tsum = tsum + t1
 
7229
    if (t1 < eps) goto 110
 
7230
    if (t1 > t2) then
 
7231
      write (6, *) 'bessel: t1 > t2; t ='
 
7232
      call mpwrite (6, t)
 
7233
      tsum = 0.d0
 
7234
      goto 110
 
7235
    endif
 
7236
  enddo
 
7237
 
 
7238
  write (6, *) 'bessel: loop overflow 2'
 
7239
  tsum = 0.d0
 
7240
 
 
7241
110 continue
 
7242
 
 
7243
  t1 = tsum * exp (t) / sqrt (2.d0 * mppic * t)
 
7244
endif
 
7245
 
 
7246
z = t1
 
7247
return
 
7248
end subroutine
 
7249
 
 
7250
subroutine mpbesselexp (t, z)
 
7251
 
 
7252
!   This evaluates the function BesselI (0, t) / exp (t).
 
7253
 
 
7254
implicit none
 
7255
integer i, ndp, nwords
 
7256
type (mp_real) eps, tsum, t, t1, t2, z
 
7257
 
 
7258
call mpgetprecwords (nwords)
 
7259
eps = mpreal (2.d0) ** (-48 * nwords - 1)
 
7260
ndp = (nwords - 2) * 7.224719896d0
 
7261
 
 
7262
!   Select either the direct or the asymptotic series.
 
7263
 
 
7264
if (0.85d0 * t < ndp) then
 
7265
  tsum = 1.d0
 
7266
  t1 = 1.d0
 
7267
  t2 = t ** 2
 
7268
 
 
7269
  do i = 1, 1000000000
 
7270
    t1 = t1 * t2 / (4.d0 * dble (i) ** 2)
 
7271
    if (t1 < eps) goto 100
 
7272
    tsum = tsum + t1
 
7273
  enddo
 
7274
 
 
7275
  write (6, *) 'besselexp: loop overflow 1'
 
7276
  tsum = 0.d0
 
7277
 
 
7278
100 continue
 
7279
 
 
7280
  t1 = tsum / exp (t)
 
7281
else
 
7282
  tsum = 1.d0
 
7283
  t1 = 1.d0
 
7284
 
 
7285
  do i = 1, 1000000000
 
7286
    t2 = t1
 
7287
    t1 = t1 * (2.d0 * i - 1.d0) ** 2 / (8.d0 * i * t)
 
7288
    tsum = tsum + t1
 
7289
    if (t1 < eps) goto 110
 
7290
    if (t1 > t2) then
 
7291
      write (6, *) 'besselexp: t1 > t2; t ='
 
7292
      call mpwrite (6, t)
 
7293
      tsum = 0.d0
 
7294
      goto 110
 
7295
    endif
 
7296
  enddo
 
7297
 
 
7298
  write (6, *) 'besselexp: loop overflow 2'
 
7299
  tsum = 0.d0
 
7300
 
 
7301
110 continue
 
7302
 
 
7303
  t1 = tsum / sqrt (2.d0 * mppic * t)
 
7304
endif
 
7305
 
 
7306
z = t1
 
7307
return
 
7308
end subroutine
 
7309
 
 
7310
subroutine mperf (t, z)
 
7311
 
 
7312
!   Computes erf = Int_0^a 2/Sqrt(pi) * e^(-t^2)
 
7313
 
 
7314
implicit none
 
7315
integer i, nw
 
7316
real*8 ds
 
7317
type (mp_real) eps, t, t0, t1, t2, t3, t4, z
 
7318
 
 
7319
if (abs (t) > 1d-4) then
 
7320
  z = 1.d0 - erfc (t)
 
7321
else
 
7322
  call mpgetprecwords (nw)
 
7323
  eps = mpreal (0.5d0) ** (mpnbt * nw + mpnbt)
 
7324
  t0 = 1.d0
 
7325
  t1 = 1.d0
 
7326
  t2 = t ** 2
 
7327
  t3 = 1.d0
 
7328
  ds = 1.d0
 
7329
 
 
7330
  do i = 1, 1000000000
 
7331
    ds = - ds
 
7332
    t3 = dble (i) * t3
 
7333
    t1 = t1 * t2
 
7334
    t4 = ds * t1 / (dble (2 * i + 1) * t3)
 
7335
    t0 = t0 + t4
 
7336
    if (abs (t4) < eps) goto 100
 
7337
  enddo
 
7338
 
 
7339
  write (6, *) 'erf: loop end error'
 
7340
  t0 = 0.d0
 
7341
 
 
7342
100 continue
 
7343
 
 
7344
  z = 2.d0 / sqrt (mppic) * t * t0
 
7345
endif
 
7346
 
 
7347
return
 
7348
end subroutine
 
7349
 
 
7350
subroutine mperfc (t, z)
 
7351
 
 
7352
!   Computes erfc(a) = 1 - Int_0^a 2/sqrt(pi) * e^(-t^2) dt.
 
7353
 
 
7354
!   This algorithm is presented in Richard Crandall's book "Topics in
 
7355
!   Advanced Scientific Computation", pg 82.  Crandall in turn references
 
7356
!   a 1968 paper by Chiarella and Reichel.
 
7357
 
 
7358
  implicit none
 
7359
  integer i, j, k, n, ndp1, ndps, ntab, nwks, nwords
 
7360
  type (mp_real) eps, f, t, t1, t2, t3, t4, t5, z
 
7361
  real*8 alpha, d1, d2, dpi, dlog10, dlog2
 
7362
  type (mp_real) etab (:)
 
7363
  allocatable etab
 
7364
  save ndps, ntab, nwks, alpha, etab
 
7365
  data ntab/0/
 
7366
 
 
7367
  call mpgetprecwords (nwords)
 
7368
  eps = mpreal(2.d0) ** (-48 * nwords - 1)
 
7369
  ndp1 = (nwords - 2) * 7.224719896d0
 
7370
  dpi = acos (-1.d0)
 
7371
  dlog10 = log (10.d0)
 
7372
  dlog2 = log (2.d0)
 
7373
  d1 = t
 
7374
  if (d1 > 10000.d0) then
 
7375
    z = 0.d0
 
7376
    goto 200
 
7377
  endif
 
7378
  d2 = dpi / d1
 
7379
 
 
7380
  if (ntab == 0 .or. ndp1 > ndps .or. nwords > nwks .or. d2 < alpha) then
 
7381
 
 
7382
!   On the first call, or if working precision has been increased, or if
 
7383
!   the argument exceeds a certain value, recalculate alpha and the etab table.
 
7384
 
 
7385
    ndps = ndp1
 
7386
    nwks = nwords
 
7387
    if (ntab > 0) deallocate (etab)
 
7388
 
 
7389
!   Multiply d1 (new alpha) by 0.95 (so we won't need to recalculate so often),
 
7390
!   then round to some nice 6-bit rational.
 
7391
 
 
7392
    d1 = 0.95d0 * min (dpi / sqrt (ndp1 * dlog10), d2)
 
7393
    n = abs (int (log (d1) / dlog2)) + 1
 
7394
    alpha = 0.5d0 ** (n + 6) * anint (d1 * 2.d0 ** (n + 6))
 
7395
    ntab = sqrt (ndp1 * dlog10) / alpha + 1.d0
 
7396
 
 
7397
!   Make sure that (alpha * ntab)^2 can be represented exactly in DP.
 
7398
!   I don't think this will ever be a problem, but check just in case.
 
7399
 
 
7400
    d2 = 2.d0 * (6.d0 + log (dble (ntab)) / dlog2)
 
7401
    if (d2 > 53.d0) then
 
7402
      write (6, *) 'mperfcx: error; contact author'
 
7403
      stop
 
7404
    endif
 
7405
 
 
7406
!    write (6, *) 'alpha, ntab, bits =', alpha, ntab, d2
 
7407
 
 
7408
    allocate (etab(ntab))
 
7409
 
 
7410
!   Calculate table of exp(-k^2*alpha^2).
 
7411
 
 
7412
    t1 = - alpha ** 2
 
7413
    t2 = exp (t1)
 
7414
    t3 = t2 ** 2
 
7415
    t4 = 1.d0
 
7416
 
 
7417
    do i = 1, ntab
 
7418
      t4 = t2 * t4
 
7419
      etab(i) = t4
 
7420
      t2 = t2 * t3
 
7421
    enddo
 
7422
  endif
 
7423
 
 
7424
  if (t == 0.d0) then
 
7425
    z = 1.d0
 
7426
    goto 200
 
7427
  endif
 
7428
 
 
7429
  t1 = 0.d0
 
7430
  t2 = t ** 2
 
7431
  t3 = exp (-t2)
 
7432
 
 
7433
  do k = 1, ntab
 
7434
 
 
7435
    t5 = etab(k) / (k ** 2 * alpha ** 2 + t2)
 
7436
    t1 = t1 + t5
 
7437
    if (abs (t5) < eps) goto 110
 
7438
  enddo
 
7439
 
 
7440
110 continue
 
7441
 
 
7442
z = t3 * alpha * t / mppic * (1.d0 / t2 + 2.d0 * t1) &
 
7443
       + 2.d0 / (1.d0 - exp (2.d0 * mppic * t / alpha))
 
7444
 
 
7445
200 continue
 
7446
 
 
7447
  return
 
7448
end subroutine
 
7449
 
 
7450
subroutine mpgamma (t, z)
 
7451
 
 
7452
!   This evaluates the gamma function, using an algorithm of R. W. Potter.
 
7453
 
 
7454
implicit none
 
7455
integer i, j, k, ndp, neps, nt, nwords
 
7456
double precision alpha, con1, con2, d1, d2
 
7457
parameter (con1 = 1.151292547d0, con2 = 1.974476770d0)
 
7458
type (mp_real) eps, sum1, sum2, t, t1, t2, t3, t4, tn, z
 
7459
 
 
7460
call mpgetprecwords (nwords)
 
7461
neps = (-nwords - 1) * 7.224719896d0
 
7462
ndp = (nwords - 1) * 7.224719896d0
 
7463
eps = mpreal(2.d0) ** (-24*nwords - 24)
 
7464
 
 
7465
!   Handle special arguments.
 
7466
 
 
7467
if (abs (t) > 1.d8) then
 
7468
  write (6, *) 'gamma: argument too large'
 
7469
  goto 120
 
7470
elseif (t == anint (t) .and. t <= 0.d0) then
 
7471
    write (6, *) 'gamma: invalid argument'
 
7472
    z = 0.d0
 
7473
    goto 120
 
7474
endif
 
7475
 
 
7476
if (t > 0.d0) then
 
7477
  nt = dble (t)
 
7478
  if (t == dble (nt)) nt = nt - 1
 
7479
  t1 = 1.d0
 
7480
 
 
7481
  do i = 1, nt
 
7482
    t1 = t1 * (t - dble (i))
 
7483
  enddo
 
7484
 
 
7485
  tn = t - dble (nt)
 
7486
  if (t == aint (t)) then
 
7487
    z = t1
 
7488
    goto 120
 
7489
  endif
 
7490
else
 
7491
  nt = 1 - t
 
7492
  t1 = 1.d0
 
7493
 
 
7494
  do i = 0, nt - 1
 
7495
    t1 = t1 / (t + dble (i))
 
7496
  enddo
 
7497
 
 
7498
  tn = t + dble (nt)
 
7499
endif
 
7500
 
 
7501
!   Calculate alpha, then take the next highest integer value, so that
 
7502
!   d2 = 0.25 * alpha^2 can be calculated exactly in double precision.
 
7503
 
 
7504
alpha = aint (con1 * ndp + 1.d0)
 
7505
t2 = tn
 
7506
d2 = 0.25d0 * alpha**2
 
7507
t3 = 1.d0 / t2
 
7508
sum1 = t3
 
7509
 
 
7510
!   Evaluate the series with t, terminating when t3 < sum1 * epsilon.
 
7511
 
 
7512
do j = 1, 1000000000
 
7513
  t3 = t3 * d2 / (j * (t2 + j))
 
7514
  sum1 = sum1 + t3
 
7515
  if (abs (t3) < abs (sum1) * eps) goto 100
 
7516
enddo
 
7517
 
 
7518
write (6, *) 'gamma: loop overflow 1'
 
7519
sum1 = 0.d0
 
7520
 
 
7521
100 continue
 
7522
 
 
7523
sum1 = t2 * (0.5d0 * alpha) ** t2 * sum1
 
7524
t2 = - tn
 
7525
t3 = 1.d0 / t2
 
7526
sum2 = t3
 
7527
 
 
7528
!   Evaluate the same series with -t, terminating when t3 < sum1 * epsilon.
 
7529
 
 
7530
do j = 1, 1000000000
 
7531
  t3 = t3 * d2 / (j * (t2 + j))
 
7532
  sum2 = sum2 + t3
 
7533
  if (abs (t3) < abs (sum2) * eps) goto 110
 
7534
enddo
 
7535
 
 
7536
write (6, *) 'gamma: loop overflow 2'
 
7537
sum2 = 0.d0
 
7538
 
 
7539
110 continue
 
7540
 
 
7541
sum2 = t2 * (0.5d0 * alpha) ** t2 * sum2
 
7542
 
 
7543
!   Conclude with this square root expression.
 
7544
 
 
7545
z = t1 * sqrt (mppic * sum1 / (tn * sin (mppic * tn) * sum2))
 
7546
 
 
7547
120 continue
 
7548
 
 
7549
return
 
7550
end subroutine
 
7551
 
 
7552
end module
 
7553
 
 
7554
module mpmodule
 
7555
use mpfunmod
 
7556
use mpintmod
 
7557
use mprealmod
 
7558
use mpcmpmod
 
7559
use mpgenmod
 
7560
use mpfunsubmod
 
7561
end module